{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Shpadoinkle.Router (
HasRouter(..), Routed(..)
, Redirect(..), Router(..), View, HTML
, fullPageSPAC, fullPageSPA, fullPageSPA'
, navigate
, withHydration, toHydration
, Raw, MonadJSM, HasLink(..)
) where
import Control.Applicative (Alternative ((<|>)))
import Control.Compactable as C (Compactable (compact, filter))
import Control.Monad (forever)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson (FromJSON, ToJSON, decode,
encode)
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Kind (Type)
import Data.Maybe (isJust)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import GHCJS.DOM (currentWindowUnchecked,
syncPoint)
import GHCJS.DOM.EventM (on)
import GHCJS.DOM.EventTargetClosures (EventName, unsafeEventName)
import GHCJS.DOM.History (pushState)
import GHCJS.DOM.Location (getPathname, getSearch)
import GHCJS.DOM.PopStateEvent (PopStateEvent)
import GHCJS.DOM.Types (JSM, MonadJSM, liftJSM)
import GHCJS.DOM.Window (Window, getHistory, getLocation)
import Language.Javascript.JSaddle (fromJSVal, jsg)
#ifndef ghcjs_HOST_OS
import Servant.API (Accept (contentTypes), Capture,
FromHttpApiData, HasLink (..),
IsElem, MimeRender (..),
QueryFlag, QueryParam,
QueryParam', QueryParams, Raw,
Required, type (:<|>) (..),
type (:>))
#else
import Servant.API (Capture, FromHttpApiData,
HasLink (..), IsElem, QueryFlag,
QueryParam, QueryParam',
QueryParams, Raw, Required,
type (:<|>) (..), type (:>))
#endif
import Servant.Links (Link, URI (..), linkURI,
safeLink)
import System.IO.Unsafe (unsafePerformIO)
import UnliftIO.Concurrent (MVar, forkIO, newEmptyMVar,
putMVar, takeMVar)
import UnliftIO.STM (TVar, atomically, newTVarIO,
writeTVar)
import Web.HttpApiData (parseQueryParamMaybe,
parseUrlPieceMaybe)
import Shpadoinkle (Backend, Continuation, Html,
RawNode, h, hoist, kleisli, pur,
shpadoinkle, text, type (~>),
writeUpdate)
#ifndef ghcjs_HOST_OS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List.NonEmpty as NE
import qualified Network.HTTP.Media as M
import Servant (Application, HasServer, Tagged)
import qualified Servant as S
import Shpadoinkle.Backend.Static (renderStatic)
#endif
default (Text)
data Router a where
RChoice :: Router a -> Router a -> Router a
RCapture :: FromHttpApiData x => (x -> Router a) -> Router a
RQueryParam :: (FromHttpApiData x, KnownSymbol sym) => Proxy sym -> (Maybe x -> Router a) -> Router a
RQueryParamR :: (FromHttpApiData x, KnownSymbol sym) => Proxy sym -> (x -> Router a) -> Router a
RQueryParams :: (FromHttpApiData x, KnownSymbol sym) => Proxy sym -> ([x] -> Router a) -> Router a
RQueryFlag :: KnownSymbol sym => Proxy sym -> (Bool -> Router a) -> Router a
RPath :: KnownSymbol sym => Proxy sym -> Router a -> Router a
RView :: a -> Router a
data Redirect api
= forall sub. (IsElem sub api, HasLink sub)
=> Redirect (Proxy sub) (MkLink sub Link -> Link)
class Routed a r where redirect :: r -> Redirect a
syncRoute :: MVar ()
syncRoute = unsafePerformIO newEmptyMVar
{-# NOINLINE syncRoute #-}
withHydration :: (MonadJSM m, FromJSON a) => (r -> m a) -> r -> m a
withHydration s r = do
i <- liftJSM $ fromJSVal =<< jsg "initState"
case decode . fromStrict . encodeUtf8 =<< i of
Just fe -> return fe
_ -> s r
toHydration :: ToJSON a => a -> Html m b
toHydration fe =
h "script" [] [ text $ "window.initState = '" <> (T.replace "'" "\\'" . decodeUtf8 . toStrict $ encode fe) <> "'" ]
navigate :: forall a m r. MonadJSM m => Routed a r => r -> m ()
navigate r = do
w <- currentWindowUnchecked
history <- getHistory w
case redirect r :: Redirect a of
Redirect pr mf -> do
let uri = linkURI . mf $ safeLink (Proxy @a) pr
pushState history () "" . Just . T.pack $
"/" ++ uriPath uri ++ uriQuery uri ++ uriFragment uri
liftIO $ putMVar syncRoute ()
fullPageSPAC :: forall layout b a r m
. HasRouter layout
=> Backend b m a
=> Monad (b m)
=> Eq a
=> Functor m
=> (m ~> JSM)
-> (TVar a -> b m ~> m)
-> (r -> m a)
-> (a -> Html (b m) a)
-> b m RawNode
-> (r -> m (Continuation m a))
-> layout :>> r
-> JSM ()
fullPageSPAC toJSM backend i' view getStage onRoute routes = do
let router = route @layout @r routes
window <- currentWindowUnchecked
getRoute window router $ \case
Nothing -> return ()
Just r -> do
i <- toJSM $ i' r
model <- newTVarIO i
_ <- listenStateChange router $ writeUpdate model . kleisli . const
. (fmap (hoist toJSM) . toJSM) . onRoute
shpadoinkle toJSM backend i model view getStage
syncPoint
fullPageSPA :: forall layout b a r m
. HasRouter layout
=> Backend b m a
=> Monad (b m)
=> Eq a
=> Functor m
=> (m ~> JSM)
-> (TVar a -> b m ~> m)
-> (r -> m a)
-> (a -> Html (b m) a)
-> b m RawNode
-> (r -> m a)
-> layout :>> r
-> JSM ()
fullPageSPA a b c v g s = fullPageSPAC @layout a b c v g (fmap (pur . const) . s)
{-# ANN fullPageSPA' ("HLint: ignore Reduce duplication" :: String) #-}
fullPageSPA' :: forall layout b a r m
. HasRouter layout
=> Backend b m a
=> Monad (b m)
=> Eq a
=> Functor m
=> (m ~> JSM)
-> (TVar a -> b m ~> m)
-> TVar a
-> (r -> m a)
-> (a -> Html (b m) a)
-> b m RawNode
-> (r -> m (Continuation m a))
-> layout :>> r
-> JSM ()
fullPageSPA' toJSM backend model i' view getStage onRoute routes = do
let router = route @layout @r routes
window <- currentWindowUnchecked
getRoute window router $ \case
Nothing -> return ()
Just r -> do
i <- toJSM $ i' r
atomically $ writeTVar model i
_ <- listenStateChange router $ writeUpdate model . kleisli . const
. (fmap (hoist toJSM) . toJSM) . onRoute
shpadoinkle toJSM backend i model view getStage
syncPoint
parseQuery :: Text -> [(Text,Text)]
parseQuery = (=<<) toKVs . T.splitOn "&" . T.drop 1
where toKVs t = case T.splitOn "=" t of
[k,v] -> [(k,v)]
_ -> []
parseSegments :: Text -> [Text]
parseSegments = C.filter (/= "") . T.splitOn "/"
popstate :: EventName Window PopStateEvent
popstate = unsafeEventName "popstate"
getRoute
:: Window -> Router r -> (Maybe r -> JSM a) -> JSM a
getRoute window router handle = do
location <- getLocation window
path <- getPathname location
search <- getSearch location
let query = parseQuery search
segs = parseSegments path
handle $ fromRouter query segs router
listenStateChange
:: Router r -> (r -> JSM ()) -> JSM ()
listenStateChange router handle = do
w <- currentWindowUnchecked
_ <- on w popstate . liftIO $ putMVar syncRoute ()
_ <- forkIO . forever $ do
liftIO $ takeMVar syncRoute
getRoute w router $ maybe (return ()) handle
syncPoint
() <- liftIO $ return ()
return ()
return ()
fromRouter :: [(Text,Text)] -> [Text] -> Router r -> Maybe r
fromRouter queries segs = \case
RChoice x y -> fromRouter queries segs x <|> fromRouter queries segs y
RCapture f -> case segs of
[] -> Nothing
capture:paths -> fromRouter queries paths . f =<< parseUrlPieceMaybe capture
RQueryParam sym f ->
case lookup (T.pack $ symbolVal sym) queries of
Nothing -> fromRouter queries segs $ f Nothing
Just t -> fromRouter queries segs $ f (parseQueryParamMaybe t)
RQueryParamR sym f ->
case lookup (T.pack $ symbolVal sym) queries of
Nothing -> Nothing
Just t -> fromRouter queries segs . f =<< parseQueryParamMaybe t
RQueryParams sym f ->
fromRouter queries segs . f . compact $ parseQueryParamMaybe . snd <$> C.filter
(\(k, _) -> k == T.pack (symbolVal sym))
queries
RQueryFlag sym f ->
fromRouter queries segs . f . isJust $ lookup (T.pack $ symbolVal sym) queries
RPath sym a -> case segs of
[] -> Nothing
p:paths -> if p == T.pack (symbolVal sym) then
fromRouter queries paths a else Nothing
RView a -> if null segs then Just a else Nothing
class HasRouter layout where
type layout :>> route :: Type
route :: layout :>> route -> Router route
infixr 4 :>>
instance (HasRouter x, HasRouter y)
=> HasRouter (x :<|> y) where
type (x :<|> y) :>> r = x :>> r :<|> y :>> r
route :: x :>> r :<|> y :>> r -> Router r
route (x :<|> y) = RChoice (route @x x) (route @y y)
{-# INLINABLE route #-}
instance (HasRouter sub, FromHttpApiData x)
=> HasRouter (Capture sym x :> sub) where
type (Capture sym x :> sub) :>> a = x -> sub :>> a
route :: (x -> sub :>> r) -> Router r
route = RCapture . (route @sub .)
{-# INLINABLE route #-}
instance (HasRouter sub, FromHttpApiData x, KnownSymbol sym)
=> HasRouter (QueryParam sym x :> sub) where
type (QueryParam sym x :> sub) :>> a = Maybe x -> sub :>> a
route :: (Maybe x -> sub :>> r) -> Router r
route = RQueryParam (Proxy @sym) . (route @sub .)
{-# INLINABLE route #-}
instance (HasRouter sub, FromHttpApiData x, KnownSymbol sym)
=> HasRouter (QueryParam' '[Required] sym x :> sub) where
type (QueryParam' '[Required] sym x :> sub) :>> a = x -> sub :>> a
route :: (x -> sub :>> r) -> Router r
route = RQueryParamR (Proxy @sym) . (route @sub .)
instance (HasRouter sub, FromHttpApiData x, KnownSymbol sym)
=> HasRouter (QueryParams sym x :> sub) where
type (QueryParams sym x :> sub) :>> a = [x] -> sub :>> a
route :: ([x] -> sub :>> r) -> Router r
route = RQueryParams (Proxy @sym) . (route @sub .)
{-# INLINABLE route #-}
instance (HasRouter sub, KnownSymbol sym)
=> HasRouter (QueryFlag sym :> sub) where
type (QueryFlag sym :> sub) :>> a = Bool -> sub :>> a
route :: (Bool -> sub :>> r) -> Router r
route = RQueryFlag (Proxy @sym) . (route @sub .)
{-# INLINABLE route #-}
instance (HasRouter sub, KnownSymbol path)
=> HasRouter ((path :: Symbol) :> sub) where
type (path :> sub) :>> a = sub :>> a
route :: sub :>> r -> Router r
route = RPath (Proxy @path) . route @sub
{-# INLINABLE route #-}
instance HasRouter Raw where
type Raw :>> a = a
route :: r -> Router r
route = RView
{-# INLINABLE route #-}
instance HasRouter (f '[HTML] (Html m b)) where
type f '[HTML] (Html m b) :>> a = a
route :: r -> Router r
route = RView
{-# INLINABLE route #-}
instance HasRouter (View m b) where
type View m b :>> a = a
route :: r -> Router r
route = RView
{-# INLINABLE route #-}
#ifndef ghcjs_HOST_OS
instance Accept HTML where
contentTypes _ =
"text" M.// "html" M./: ("charset", "utf-8") NE.:|
["text" M.// "html"]
instance MimeRender HTML (Html m a) where
mimeRender _ = BSL.fromStrict . encodeUtf8 . renderStatic
instance HasServer (View m a) context where
type ServerT (View m a) m' = Tagged m' Application
route _ = S.route (Proxy @Raw)
hoistServerWithContext _ = S.hoistServerWithContext (Proxy @Raw)
#endif
data HTML :: Type
data View :: (Type -> Type) -> Type -> Type
instance HasLink (View m a) where
type MkLink (View m a) b = b
toLink toA _ = toA