Base URL portability, better 404 page

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)

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"

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
 

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 <> "<br>" <> wher
         dayMarker d@TourDay{..} = case dayFromCoord <|> dayToCoord of

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