{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- | Typed routes shared by native tests and GHC's JavaScript backend. Use
-- "Web.Spock.Browser.History" to attach a compiled router to browser navigation.
module Web.Spock.Browser
  ( Routes, Router, route, compileRoutes, dispatch,
    Location (..), NavigationError (..), parseLocation, renderPath,
    Path, PathState (..), root, static, var, wildcard, trailingSlash,
    (<//>), (<.>), SlashPolicy (..)
  ) where

import Control.Monad (unless)
import Data.HVect (AllHave, Append, HVect, HVectElim)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types.URI (urlDecode)
import Web.HttpApiData (ToHttpApiData)
import Web.Routing.Combinators hiding ((</>))
import qualified Web.Routing.Combinators as R
import Web.Routing.Router
import Web.Routing.SafeRouting (HVectElim' (..), SlashPolicy (..))

-- | A registry of navigation handlers, using the same typed captures as Spock.
type Routes = RegistryT IO () () () IO ()

-- | A compiled registry. 'dispatch' executes its first matching handler.
newtype Router = Router ([T.Text] -> [IO ()])

-- | Register a route. Handler arguments follow the typed path captures.
route :: Path as ps -> HVectElim as (IO ()) -> Routes
route :: forall (as :: [*]) (ps :: PathState).
Path as ps -> HVectElim as (IO ()) -> Routes
route Path as ps
path HVectElim as (IO ())
handler = PathInternal as -> HVectElim' (IO ()) as -> Routes
forall (m :: * -> *) (as :: [*]) (n :: * -> *) b middleware
       reqTypes.
Monad m =>
PathInternal as
-> HVectElim' (n b) as -> RegistryT n b middleware reqTypes m ()
hookRouteAnyMethod (Path as ps -> PathInternal as
forall (as :: [*]) (pathState :: PathState).
Path as pathState -> PathInternal as
toInternalPath Path as ps
path) (HVectElim as (IO ()) -> HVectElim' (IO ()) as
forall x (ts :: [*]). HVectElim ts x -> HVectElim' x ts
HVectElim' HVectElim as (IO ())
handler)

-- | Compile definitions once. IgnoreSlashes is Spock's compatibility policy.
-- StrictSlashes preserves empty segments. RedirectTrailingSlashes uses strict
-- matching here; canonical HTTP redirects belong to the server adapter.
compileRoutes :: SlashPolicy -> Routes -> IO Router
compileRoutes :: SlashPolicy -> Routes -> IO Router
compileRoutes SlashPolicy
policy Routes
definitions = do
  (_, match, _) <- SlashPolicy -> Routes -> IO ((), () -> [Text] -> [IO ()], [()])
forall (m :: * -> *) reqTypes (n :: * -> *) b middleware a.
(Monad m, Hashable reqTypes, Eq reqTypes) =>
SlashPolicy
-> RegistryT n b middleware reqTypes m a
-> m (a, reqTypes -> [Text] -> [n b], [middleware])
runRegistryWith SlashPolicy
policy Routes
definitions
  pure $ Router (match ())

-- | Run the first match, returning False when no route matched. Handler
-- exceptions propagate; no alternative handler runs after a successful match.
dispatch :: Router -> Location -> IO Bool
dispatch :: Router -> Location -> IO Bool
dispatch (Router [Text] -> [IO ()]
match) Location
location = case [Text] -> [IO ()]
match (Location -> [Text]
locationSegments Location
location) of
  [] -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  IO ()
handler : [IO ()]
_ -> IO ()
handler IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

-- | A validated local URL. Query and fragment remain encoded, with their
-- leading '?' and '#'. Path captures are percent-decoded once, segment by
-- segment, so an encoded slash remains inside its captured value.
data Location = Location
  { Location -> Text
locationPathname :: T.Text,
    Location -> [Text]
locationSegments :: [T.Text],
    Location -> Text
locationQuery :: T.Text,
    Location -> Text
locationFragment :: T.Text
  } deriving (Location -> Location -> Bool
(Location -> Location -> Bool)
-> (Location -> Location -> Bool) -> Eq Location
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
/= :: Location -> Location -> Bool
Eq, Int -> Location -> ShowS
[Location] -> ShowS
Location -> String
(Int -> Location -> ShowS)
-> (Location -> String) -> ([Location] -> ShowS) -> Show Location
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Location -> ShowS
showsPrec :: Int -> Location -> ShowS
$cshow :: Location -> String
show :: Location -> String
$cshowList :: [Location] -> ShowS
showList :: [Location] -> ShowS
Show)

-- | Failures omit the rejected URL and any sensitive query values.
data NavigationError = InvalidLocation | OutsideScope | HistoryUnavailable
  | AlreadyMounted | RouterStopped
  deriving (NavigationError -> NavigationError -> Bool
(NavigationError -> NavigationError -> Bool)
-> (NavigationError -> NavigationError -> Bool)
-> Eq NavigationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NavigationError -> NavigationError -> Bool
== :: NavigationError -> NavigationError -> Bool
$c/= :: NavigationError -> NavigationError -> Bool
/= :: NavigationError -> NavigationError -> Bool
Eq, Int -> NavigationError -> ShowS
[NavigationError] -> ShowS
NavigationError -> String
(Int -> NavigationError -> ShowS)
-> (NavigationError -> String)
-> ([NavigationError] -> ShowS)
-> Show NavigationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NavigationError -> ShowS
showsPrec :: Int -> NavigationError -> ShowS
$cshow :: NavigationError -> String
show :: NavigationError -> String
$cshowList :: [NavigationError] -> ShowS
showList :: [NavigationError] -> ShowS
Show)

-- | Parse an absolute local path with optional query/fragment. Reject external
-- origins, malformed escapes/UTF-8, and dot segments browsers would normalize.
parseLocation :: T.Text -> Either NavigationError Location
parseLocation :: Text -> Either NavigationError Location
parseLocation Text
value = do
  Bool -> Either NavigationError () -> Either NavigationError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Text -> Bool
T.isPrefixOf Text
"/" Text
value Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Text -> Bool
T.isPrefixOf Text
"//" Text
value)
    Bool -> Bool -> Bool
&& Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\DEL') Text
value)) (Either NavigationError () -> Either NavigationError ())
-> Either NavigationError () -> Either NavigationError ()
forall a b. (a -> b) -> a -> b
$ NavigationError -> Either NavigationError ()
forall a b. a -> Either a b
Left NavigationError
InvalidLocation
  let (Text
beforeFragment, Text
fragment) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"#" Text
value
      (Text
pathname, Text
query) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"?" Text
beforeFragment
      pieces :: [Text]
pieces = if Text
pathname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"/" then [] else HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" (Int -> Text -> Text
T.drop Int
1 Text
pathname)
  decoded <- (Text -> Either NavigationError Text)
-> [Text] -> Either NavigationError [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Text -> Either NavigationError Text
decodePiece [Text]
pieces
  unless (all (`notElem` [".", ".."]) decoded) $ Left InvalidLocation
  pure $ Location pathname decoded query fragment
  where
    decodePiece :: Text -> Either NavigationError Text
decodePiece Text
piece = do
      Bool -> Either NavigationError () -> Either NavigationError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
validEscapes (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
piece) (Either NavigationError () -> Either NavigationError ())
-> Either NavigationError () -> Either NavigationError ()
forall a b. (a -> b) -> a -> b
$ NavigationError -> Either NavigationError ()
forall a b. a -> Either a b
Left NavigationError
InvalidLocation
      (UnicodeException -> Either NavigationError Text)
-> (Text -> Either NavigationError Text)
-> Either UnicodeException Text
-> Either NavigationError Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either NavigationError Text
-> UnicodeException -> Either NavigationError Text
forall a b. a -> b -> a
const (Either NavigationError Text
 -> UnicodeException -> Either NavigationError Text)
-> Either NavigationError Text
-> UnicodeException
-> Either NavigationError Text
forall a b. (a -> b) -> a -> b
$ NavigationError -> Either NavigationError Text
forall a b. a -> Either a b
Left NavigationError
InvalidLocation) Text -> Either NavigationError Text
forall a b. b -> Either a b
Right (Either UnicodeException Text -> Either NavigationError Text)
-> Either UnicodeException Text -> Either NavigationError Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
T.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
urlDecode Bool
False (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
piece
    validEscapes :: String -> Bool
validEscapes [] = Bool
True
    validEscapes (Char
'%' : Char
a : Char
b : String
rest) = Char
a Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
hex Bool -> Bool -> Bool
&& Char
b Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
hex Bool -> Bool -> Bool
&& String -> Bool
validEscapes String
rest
    validEscapes (Char
'%' : String
_) = Bool
False
    validEscapes (Char
_ : String
rest) = String -> Bool
validEscapes String
rest
    hex :: String
hex = String
"0123456789abcdefABCDEF" :: String

-- | Render a safe local href using the same path and slash policy as the
-- registry. Values are encoded as complete segments, including extensions.
renderPath :: AllHave ToHttpApiData as => SlashPolicy -> Path as 'Open -> HVect as -> Either NavigationError T.Text
renderPath :: forall (as :: [*]).
AllHave ToHttpApiData as =>
SlashPolicy
-> Path as 'Open -> HVect as -> Either NavigationError Text
renderPath SlashPolicy
policy Path as 'Open
path HVect as
arguments = do
  let href :: Text
href = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SlashPolicy -> Path as 'Open -> HVect as -> Text
forall (as :: [*]).
AllHave ToHttpApiData as =>
SlashPolicy -> Path as 'Open -> HVect as -> Text
renderRouteEncodedWith SlashPolicy
policy Path as 'Open
path HVect as
arguments
  _ <- Text -> Either NavigationError Location
parseLocation Text
href
  pure href

-- | Append path components, using Spock's familiar operator spelling.
(<//>) :: Path as 'Open -> Path bs ps -> Path (Append as bs) ps
<//> :: forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
(<//>) = Path as 'Open -> Path bs ps -> Path (Append as bs) ps
forall (as :: [*]) (bs :: [*]) (ps :: PathState).
Path as 'Open -> Path bs ps -> Path (Append as bs) ps
(R.</>)
infixl 5 <//>