{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Scoped History API navigation. Mount one router per window, and call
-- 'unmountRouter' when its owner is removed. Same-origin links inside the scope
-- are intercepted; external, download, modified and same-page anchor clicks
-- retain their browser behavior. popstate and hashchange are deduplicated.
module Web.Spock.Browser.History
  ( BrowserConfig (..), MountedRouter, HistoryMode (..), mountRouter,
    navigate, currentLocation, unmountRouter
  ) where

import Control.Concurrent.MVar
import Control.Exception (mask, mask_, onException)
import Control.Monad (unless, when)
import Data.IORef
import qualified Data.Text as T
import GHC.JS.Foreign.Callback
import GHC.JS.Prim
import Web.Spock.Browser

-- | Explicit URL scope and application handlers. Scope is '/' or an absolute
-- path prefix such as '/app'; prefix matching respects segment boundaries.
data BrowserConfig = BrowserConfig
  { BrowserConfig -> Text
bc_scope :: T.Text,
    BrowserConfig -> Location -> IO ()
bc_notFound :: Location -> IO (),
    BrowserConfig -> NavigationError -> IO ()
bc_navigationError :: NavigationError -> IO ()
  }

-- | Owned listeners and callback. 'unmountRouter' is idempotent. Queued events
-- are ignored after unmount; a handler already running is allowed to finish.
data MountedRouter = MountedRouter JSVal (Callback (JSVal -> IO ())) (IORef Bool)

-- | Add a history entry or replace the current entry. Navigating to the current
-- URL rerenders without adding a duplicate history entry.
data HistoryMode = Push | Replace deriving (HistoryMode -> HistoryMode -> Bool
(HistoryMode -> HistoryMode -> Bool)
-> (HistoryMode -> HistoryMode -> Bool) -> Eq HistoryMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HistoryMode -> HistoryMode -> Bool
== :: HistoryMode -> HistoryMode -> Bool
$c/= :: HistoryMode -> HistoryMode -> Bool
/= :: HistoryMode -> HistoryMode -> Bool
Eq, Int -> HistoryMode -> ShowS
[HistoryMode] -> ShowS
HistoryMode -> String
(Int -> HistoryMode -> ShowS)
-> (HistoryMode -> String)
-> ([HistoryMode] -> ShowS)
-> Show HistoryMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HistoryMode -> ShowS
showsPrec :: Int -> HistoryMode -> ShowS
$cshow :: HistoryMode -> String
show :: HistoryMode -> String
$cshowList :: [HistoryMode] -> ShowS
showList :: [HistoryMode] -> ShowS
Show)

-- | Attach listeners and synchronously render the current in-scope URL.
-- Navigation handlers run serially, in event order. Mounting twice returns
-- AlreadyMounted; if the initial handler throws, listeners are cleaned up.
mountRouter :: BrowserConfig -> Router -> IO (Either NavigationError MountedRouter)
mountRouter :: BrowserConfig
-> Router -> IO (Either NavigationError MountedRouter)
mountRouter BrowserConfig
cfg Router
router = case Text -> Either NavigationError Location
parseLocation (BrowserConfig -> Text
bc_scope BrowserConfig
cfg) of
  Left NavigationError
err -> Either NavigationError MountedRouter
-> IO (Either NavigationError MountedRouter)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NavigationError MountedRouter
 -> IO (Either NavigationError MountedRouter))
-> Either NavigationError MountedRouter
-> IO (Either NavigationError MountedRouter)
forall a b. (a -> b) -> a -> b
$ NavigationError -> Either NavigationError MountedRouter
forall a b. a -> Either a b
Left NavigationError
err
  Right Location
scope | Bool -> Bool
not (Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Location -> Text
locationQuery Location
scope) Bool -> Bool -> Bool
|| Bool -> Bool
not (Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Location -> Text
locationFragment Location
scope) -> Either NavigationError MountedRouter
-> IO (Either NavigationError MountedRouter)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NavigationError MountedRouter
 -> IO (Either NavigationError MountedRouter))
-> Either NavigationError MountedRouter
-> IO (Either NavigationError MountedRouter)
forall a b. (a -> b) -> a -> b
$ NavigationError -> Either NavigationError MountedRouter
forall a b. a -> Either a b
Left NavigationError
InvalidLocation
  Right Location
_ -> ((forall a. IO a -> IO a)
 -> IO (Either NavigationError MountedRouter))
-> IO (Either NavigationError MountedRouter)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a)
  -> IO (Either NavigationError MountedRouter))
 -> IO (Either NavigationError MountedRouter))
-> ((forall a. IO a -> IO a)
    -> IO (Either NavigationError MountedRouter))
-> IO (Either NavigationError MountedRouter)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    active <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
    lock <- newMVar ()
    let run JSVal
value = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \() -> do
          alive <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
active
          when alive $ do
            code <- fromJSInt <$> getProp value "error"
            if code /= 0 then bc_navigationError cfg (fromCode code) else do
              url <- T.pack . fromJSString <$> getProp value "url"
              case parseLocation url of
                Left NavigationError
err -> BrowserConfig -> NavigationError -> IO ()
bc_navigationError BrowserConfig
cfg NavigationError
err
                Right Location
location -> Router -> Location -> IO Bool
dispatch Router
router Location
location IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
matched -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
matched (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ BrowserConfig -> Location -> IO ()
bc_notFound BrowserConfig
cfg Location
location
    callback <- asyncCallback1 run
    handle <- js_mount (toJSString $ T.unpack $ bc_scope cfg) callback `onException` releaseCallback callback
    code <- fromJSInt <$> getProp handle "error"
    if code /= 0 then releaseCallback callback >> pure (Left $ fromCode code) else do
      let mounted = JSVal -> Callback (JSVal -> IO ()) -> IORef Bool -> MountedRouter
MountedRouter JSVal
handle Callback (JSVal -> IO ())
callback IORef Bool
active
      restore (js_initial handle >>= \JSVal
value -> do
        present <- JSVal -> Int
fromJSInt (JSVal -> Int) -> IO JSVal -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSVal -> String -> IO JSVal
getProp JSVal
value String
"present"
        when (present /= 0) $ run value) `onException` unmountRouter mounted
      pure $ Right mounted

-- | Navigate to a validated local URL within this router's scope. Rendering is
-- queued through the same callback as link clicks, so handlers may navigate
-- again without deadlocking. History API failures leave rendering unchanged.
navigate :: MountedRouter -> HistoryMode -> T.Text -> IO (Either NavigationError ())
navigate :: MountedRouter
-> HistoryMode -> Text -> IO (Either NavigationError ())
navigate (MountedRouter JSVal
handle Callback (JSVal -> IO ())
_ IORef Bool
active) HistoryMode
mode Text
url = do
  alive <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
active
  if not alive then pure $ Left RouterStopped else case parseLocation url of
    Left NavigationError
err -> Either NavigationError () -> IO (Either NavigationError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either NavigationError () -> IO (Either NavigationError ()))
-> Either NavigationError () -> IO (Either NavigationError ())
forall a b. (a -> b) -> a -> b
$ NavigationError -> Either NavigationError ()
forall a b. a -> Either a b
Left NavigationError
err
    Right Location
_ -> do
      code <- JSVal -> Bool -> JSVal -> IO Int
js_navigate JSVal
handle (HistoryMode
mode HistoryMode -> HistoryMode -> Bool
forall a. Eq a => a -> a -> Bool
== HistoryMode
Replace) (String -> JSVal
toJSString (String -> JSVal) -> String -> JSVal
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
url)
      pure $ if code == 0 then Right () else Left (fromCode code)

-- | Read the current browser path, query and fragment without exposing origin
-- or credentials. Query strings remain encoded for application-specific parsing.
currentLocation :: IO (Either NavigationError Location)
currentLocation :: IO (Either NavigationError Location)
currentLocation = Text -> Either NavigationError Location
parseLocation (Text -> Either NavigationError Location)
-> (JSVal -> Text) -> JSVal -> Either NavigationError Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (JSVal -> String) -> JSVal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> String
fromJSString (JSVal -> Either NavigationError Location)
-> IO JSVal -> IO (Either NavigationError Location)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO JSVal
js_location

-- | Remove all listeners and release the Haskell callback exactly once.
unmountRouter :: MountedRouter -> IO ()
unmountRouter :: MountedRouter -> IO ()
unmountRouter (MountedRouter JSVal
handle Callback (JSVal -> IO ())
callback IORef Bool
active) = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  wasActive <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
active (\Bool
old -> (Bool
False, Bool
old))
  when wasActive $ js_unmount handle >> releaseCallback callback

fromCode :: Int -> NavigationError
fromCode :: Int -> NavigationError
fromCode Int
1 = NavigationError
InvalidLocation
fromCode Int
2 = NavigationError
OutsideScope
fromCode Int
4 = NavigationError
AlreadyMounted
fromCode Int
5 = NavigationError
RouterStopped
fromCode Int
_ = NavigationError
HistoryUnavailable

foreign import javascript unsafe "h$spock_history_mount"
  js_mount :: JSVal -> Callback (JSVal -> IO ()) -> IO JSVal
foreign import javascript unsafe "h$spock_history_initial"
  js_initial :: JSVal -> IO JSVal
foreign import javascript unsafe "h$spock_history_navigate"
  js_navigate :: JSVal -> Bool -> JSVal -> IO Int
foreign import javascript unsafe "h$spock_history_unmount"
  js_unmount :: JSVal -> IO ()
foreign import javascript unsafe "(() => location.pathname + location.search + location.hash)"
  js_location :: IO JSVal