From a1c22ad4ecb251709e880739863831f414df17c6 Mon Sep 17 00:00:00 2001 From: Rodney Lorrimar Date: Fri, 20 Oct 2017 08:27:37 +0100 Subject: [PATCH] Base URL portability, better 404 page --- common/App.hs | 45 ++++++++++++++++++++++++++++++++++----------- common/AppTypes.hs | 12 +++++++----- common/Util.hs | 14 ++++++++++++++ frontend/Main.hs | 42 +++++++++++++++++++----------------------- frontend/tour.sass | 6 +++--- 5 files changed, 77 insertions(+), 42 deletions(-) diff --git a/common/App.hs b/common/App.hs index 1d05205..5e1499f 100644 --- a/common/App.hs +++ b/common/App.hs @@ -20,7 +20,7 @@ import Data.Map (Map) import Data.Proxy import Servant.API import Servant.Utils.Links -import Network.URI (relativeTo, parseURI, parseRelativeReference) +import Network.URI (relativeTo, relativeFrom, parseURI, parseRelativeReference, URI(..), uriIsAbsolute) import Data.Aeson (Value(..)) import Data.Maybe import Data.Time.Calendar (Day) @@ -86,7 +86,9 @@ routeViewDay (ViewTourDay _ d) = Just d routeViewDay _ = Nothing initModel :: Config -> URI -> Model -initModel cfg uri = Model cfg uri ViewAll mempty mempty mempty Nothing mempty mempty mempty True +initModel cfg uri = Model cfg uri' ViewAll mempty mempty mempty Nothing mempty mempty mempty True + where + uri' = unfixURI' (cfgBaseURI cfg) uri -- | Action data Action @@ -155,7 +157,7 @@ tourSummaryView' name Tour{..} m = div_ [class_ "tour-page-index"] [ p_ [class_ "tour-description"] [ text $ toMisoString tourDescription ] , nav_ [class_ "tour-nav"] [ toggleContentButton "Table" (showContent m) ] - , a_ [class_ "button is-primary is-outlined", onClick goTourList] + , a_ [class_ "button is-link is-outlined", onClick goTourList] (iconButton "arrow-up" "All the tours") ] ] @@ -263,7 +265,7 @@ tourDayNav name tour day = nav_ [class_ "tour-nav"] (iconButtonL "arrow-right" "Next Day ") ] where - cls p = class_ $ "button is-primary" <> if p then "" else " is-outlined" + cls p = class_ $ "button is-link" <> if p then "" else " is-outlined" attrs nav = case nav of Just d -> [onClick (goTourDay name (dayDate d))] Nothing -> [disabled_ "disabled"] @@ -289,10 +291,14 @@ tourDayFromModel :: MisoString -> Day -> Model -> Maybe TourDay tourDayFromModel name day m = M.lookup name (infoTour m) >>= getTourDay day -the404 :: Model -> View Action -the404 _ = div_ [] [ - text "the 404 :(" - , button_ [ onClick goTourList, class_ "button" ] [ text "go tourList" ] +the404 :: View Action +the404 = div_ [class_ "the404"] [ + div_ [class_ "container content"] + [ h1_ [class_ "title"] [text "the 404"] + , i_ [class_ "fa fa-meh-o fa-5x"] [] + , p_ [] [text "That link was not found."] + , button_ [ onClick goTourList, class_ "button is-large is-link" ] [ text "Go to tour list" ] + ] ] -- | Type-level routes @@ -331,6 +337,23 @@ uriTourDay name date = linkURI (safeLink api tourDayView name date) --linkHref :: URI -> attrs linkHref uri = href_ . toMisoString $ "/" <> show uri -fixUri :: URI -> URI -fixUri = flip relativeTo base - where Just base = parseRelativeReference "/" +-- | Add base href to a URL path. +fixURI' :: URI -> URI -> URI +fixURI' base = flip relativeTo base + +fixURI :: Model -> URI -> URI +fixURI m = fixURI' (cfgBaseURI $ config m) + +-- | Remove base href from a URL path. +-- This is ugly and nasty. +unfixURI' :: URI -> URI -> URI +unfixURI' base u = relativeFrom (unWeird u) base `relativeTo` root + where + Just root = parseRelativeReference "/" + unWeird :: URI -> URI + unWeird u | weird = u { uriScheme = "", uriAuthority = Nothing, uriPath = "/" ++ uriPath u } + | otherwise = u + where weird = uriIsAbsolute u && take 1 (uriPath u) /= "/" + +unfixURI :: Model -> URI -> URI +unfixURI m = unfixURI' (cfgBaseURI $ config m) diff --git a/common/AppTypes.hs b/common/AppTypes.hs index 0161710..d947803 100644 --- a/common/AppTypes.hs +++ b/common/AppTypes.hs @@ -5,10 +5,11 @@ module AppTypes where -import Network.URI (URI(..), parseURI) +import Network.URI import GHC.Generics import Miso.String import Data.Time.Calendar (Day) +import Data.Maybe (fromMaybe) #ifdef GHCJS_BROWSER import Servant.API @@ -44,10 +45,11 @@ data Config = Config , cfgMapBoxToken :: MisoString } deriving (Eq, Show) -initConfig :: Config -initConfig = Config{..} +initConfig :: Maybe URI -> Config +initConfig base = Config{..} where - cfgBaseURI = URI "" Nothing "/" "" "" - cfgStaticURI = URI "" Nothing "/static/" "" "" + Just static = parseURIReference "static/" + cfgBaseURI = fromMaybe (URI "" Nothing "/" "" "") base + cfgStaticURI = relativeTo static cfgBaseURI Just cfgBlogUrl = parseURI "https://rodney.id.au/posts/" cfgMapBoxToken = "pk.eyJ1IjoicnZsIiwiYSI6ImMzNzdiNWQ1YTMzYTRjNzEyOTU2ZTY2NDhiNTQ5MDBhIn0.out7-ubBjWy-7C_FH4WUHQ" diff --git a/common/Util.hs b/common/Util.hs index 0f8d078..566234e 100644 --- a/common/Util.hs +++ b/common/Util.hs @@ -3,6 +3,7 @@ module Util where import qualified Data.Text as T +import Network.URI #ifdef GHCJS_BROWSER import GHCJS.Types (JSString, JSVal, nullRef) @@ -26,6 +27,16 @@ foreign import javascript unsafe "$r = document.getElementById($1);" getElementById :: JSString -> IO (Maybe JSVal) getElementById = fmap nullableToMaybe . js_getElementById + +foreign import javascript unsafe "(function() { var base = document.getElementsByTagName('base')[0]; return base ? base.href : null; })()" + js_getBaseHref :: IO (Nullable JSString) + +getBaseURI :: IO (Maybe URI) +getBaseURI = (>>= parseRelative) <$> getBaseHref + where + getBaseHref = fmap fromMisoString . nullableToMaybe <$> js_getBaseHref + parseRelative = (>>= parseRelativeReference) . fmap uriPath . parseURIReference + -- | Opposite of toMisoString misoText :: JSString -> T.Text -- fixme: there's probably a better way @@ -35,6 +46,9 @@ fromMisoString :: JSString -> String fromMisoString = JS.unpack #else +getBaseURI :: IO (Maybe URI) +getBaseURI = pure $ parseURIReference "/" + misoText :: T.Text -> T.Text misoText = id diff --git a/frontend/Main.hs b/frontend/Main.hs index 15d61b7..1d283eb 100644 --- a/frontend/Main.hs +++ b/frontend/Main.hs @@ -51,16 +51,17 @@ import Fetch -- | Main entry point main :: IO () main = do + cfg <- initConfig <$> getBaseURI currentURI <- getCurrentURI - ref <- newIORef (nullContext initConfig) - startApp App { model = initModel initConfig currentURI + ref <- newIORef (nullContext cfg) + startApp App { model = initModel cfg currentURI , update = updateModel ref, ..} where initialAction = Init events = defaultEvents subs = [ uriSub HandleURI , layerClickSub HandleLayerClick ] - view m = either (const $ the404 m) (mainView m) $ + view m = either (const $ mainView m the404) (mainView m) $ runRoute (Proxy :: Proxy ClientRoutes) clientHandlers m -- | HasURI typeclass instance @@ -76,9 +77,9 @@ updateModel :: IORef Context -> Action -> Model -> Effect Action Model updateModel ref Init m = m <# do initContext (config m) ref pure NoOp -updateModel _ (HandleURI u) m = Effect (m { uri = u }) (viewHook m) +updateModel _ (HandleURI u) m = Effect (m { uri = unfixURI m u }) (viewHook m) updateModel _ (ChangeURI u) m = m <# do - pushURI (fixUri u) + pushURI (fixURI m u) pure NoOp updateModel ref (SetRouteView v) m = (m { routeView = v }) <# do ctx <- readIORef ref @@ -180,9 +181,9 @@ nullContext cfg = Context noop noop (const $ const noop) noop (newFetchCache cfg where noop = const $ pure () initContext :: Config -> IORef Context -> IO () -initContext cfg@Config{..} ref = do +initContext cfg ref = do updateElevChart <- initElevChartContext - (setMapData, setMapView, ctxSetInfoTour) <- initMapViewContext cfgMapBoxToken + (setMapData, setMapView, ctxSetInfoTour) <- initMapViewContext cfg writeIORef ref Context { fetchCache = newFetchCache cfg, .. } ---------------------------------------------------------------------------- @@ -214,16 +215,19 @@ initLeaflet accessToken sel = do addLayer l mapbox return l -testFunc :: FetchThing GeoData -> String -testFunc _ = "yo" - -initMapViewContext :: MisoString -> IO ( FetchThing GeoData -> GeoData -> Model -> IO () - , RouteView -> IO () - , Tour -> IO () ) -initMapViewContext mapBoxToken = do +initMapViewContext :: Config + -> IO ( FetchThing GeoData -> GeoData -> Model -> IO () + , RouteView -> IO () + , Tour -> IO () ) +initMapViewContext Config{..} = do stateRef <- newMVar (MapState ViewAll Nothing Nothing Nothing Nothing []) - leaflet <- initLeaflet mapBoxToken "tour-map" + leaflet <- initLeaflet cfgMapBoxToken "tour-map" + + let icon = newIcon (toMisoString . show $ cfgStaticURI) + blueIcon <- icon "blue" + greenIcon <- icon "green" + redIcon <- icon "red" let updateView = withMVar stateRef (updateVisibilityZoom leaflet) @@ -241,8 +245,6 @@ initMapViewContext mapBoxToken = do setMapView view = modifyMap (pure . (msView .~ view)) setMapData fetch geo model = modifyMap $ \s -> do - putStrLn $ "updating map data " ++ show fetch - let llayer :: Lens' MapState (Maybe MapLayer) llayer = case fetch of FTrackAll -> msLayerAll @@ -268,16 +270,10 @@ initMapViewContext mapBoxToken = do pure (s & (llayer .~ (Just layer))) ctxSetInfoTour Tour{..} = modifyMap $ \s -> do - putStrLn "setInfoTour" - -- clear out existing info layers removeMaybe (s ^. msInfoTour) mapM_ (removeLayer leaflet . snd) (s ^. msInfoDaily) - blueIcon <- newIcon "/static/" "blue" - greenIcon <- newIcon "/static/" "green" - redIcon <- newIcon "/static/" "red" - let popup TourDay{..} wher = "Day " <> toMisoString (show dayNum) <> ". " <> formatDate dayDate <> "
" <> wher dayMarker d@TourDay{..} = case dayFromCoord <|> dayToCoord of diff --git a/frontend/tour.sass b/frontend/tour.sass index c9ae785..a656dab 100644 --- a/frontend/tour.sass +++ b/frontend/tour.sass @@ -59,7 +59,7 @@ $mobile-split: 50vh bottom: 0 pointer-events: none -.tour-list, .tour-day, .tour-page-index +.tour-list, .tour-day, .tour-page-index, .the404 & > header, & > section pointer-events: all @@ -77,7 +77,7 @@ $mobile-split: 50vh max-height: 20vh .main-view - & > .tour-list, & > .tour-day, & > .tour-page-index + & > .tour-list, & > .tour-day, & > .tour-page-index, & > .the404 position: absolute left: 0 right: 0 @@ -172,7 +172,7 @@ $mobile-split: 50vh z-index: 1001 .main-view - & > .tour-list, & > .tour-day, & > .tour-page-index + & > .tour-list, & > .tour-day, & > .tour-page-index, & > .the404 pointer-events: all position: absolute right: 0