Permalink
Cannot retrieve contributors at this time
{-# LANGUAGE RecordWildCards #-} | |
{-# LANGUAGE NamedFieldPuns #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TypeOperators #-} | |
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE CPP #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE GADTs #-} | |
{-# LANGUAGE StandaloneDeriving #-} | |
{-# LANGUAGE ExistentialQuantification #-} | |
module App where | |
import qualified Data.Map as M | |
import Data.Monoid | |
import Data.Text (Text) | |
import qualified Data.Text as T | |
import Data.Map (Map) | |
import Data.Proxy | |
import Servant.API | |
import Servant.Utils.Links | |
import Network.URI (relativeTo, relativeFrom, parseURI, parseRelativeReference, URI(..), uriIsAbsolute) | |
import Data.Aeson (Value(..)) | |
import Data.Maybe | |
import Data.Time.Calendar (Day) | |
import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM) | |
import Miso | |
import Miso.String (MisoString, toMisoString) | |
import Data.List (find) | |
import Data.String (IsString(..)) | |
import Control.Monad (join) | |
import Types | |
import AppTypes | |
import Fetch | |
import Util | |
-- | We can pretty much share everything | |
-- | |
-- model, action, view, router, links, events map | |
-- decoders are all shareable | |
-- | Model | |
data Model | |
= Model | |
{ config :: Config | |
-- ^ uri options | |
, uri :: URI | |
-- ^ current URI of application | |
, routeView :: RouteView | |
-- ^ description of current route | |
, infoIndex :: Maybe (Map Text Tour) | |
-- ^ Summaries of tours | |
, infoTour :: Map MisoString Tour | |
-- ^ detailed tour informations by name | |
, blogHtml :: Map Day (Maybe MisoString) | |
-- ^ blog html by date | |
, trackAll :: Maybe GeoData | |
-- ^ all tracks geojson | |
, trackTour :: Map MisoString GeoData | |
-- ^ tour geojson | |
, trackDaily :: Map Day GeoData | |
-- ^ track for a day | |
, elevDaily :: Map Day [ElevPoint] | |
-- ^ elevation data for a day | |
, showContent :: Bool | |
-- ^ whether to show text/tables/etc | |
} deriving (Eq, Show) | |
-- makeLenses ''Model | |
data RouteView = ViewAll | |
| ViewTour MisoString | |
| ViewTourDay MisoString Day | |
deriving (Show, Eq) | |
-- maybe put this back in Main.hs if it doesn't work | |
-- descView :: ClientRoutes -> RouteView | |
descView = descSummary :<|> descDay :<|> descAll | |
where | |
descAll m = Just ViewAll | |
descSummary name m = Just $ ViewTour name | |
descDay name day m = Just $ ViewTourDay name day | |
routeViewTour :: RouteView -> Maybe MisoString | |
routeViewTour ViewAll = Nothing | |
routeViewTour (ViewTour t) = Just t | |
routeViewTour (ViewTourDay t _) = Just t | |
routeViewDay :: RouteView -> Maybe Day | |
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 | |
where | |
uri' = unfixURI' (cfgBaseURI cfg) uri | |
-- | Action | |
data Action | |
= Init | |
| HandleURI URI | |
| ChangeURI URI | |
| SetTitle MisoString | |
| SetRouteView RouteView | |
| ToggleContent | |
| HandleLayerClick MisoString | |
| forall a. (Show a, Eq a) => FetchData (FetchThing a) | |
| forall a. (Show a, Eq a) => SetData (FetchThing a) a | |
| NoOp | |
deriving instance Show Action | |
instance Eq Action where | |
NoOp == NoOp = True | |
a == b = show a == show b -- cheap hack | |
---------------------------------------------------------------------------- | |
mainView :: Model -> View Action -> View Action | |
mainView m v = div_ [class_ "tour-main"] | |
[ div_ [class_ "tour-map-container"] [tourMap m] | |
, div_ [class_ "elev-chart-container", id_ "elev-chart-container"] $ elevChart m | |
, div_ [class_ "main-view"] [v] | |
] | |
clientHandlers = tourSummaryView :<|> tourDayView :<|> tourList | |
tourList :: Model -> View Action | |
tourList m@Model{..} = div_ [class_ "tour-list"] | |
[ header_ [] | |
[ h1_ [] [ text "All the tours" ] | |
, div_ [class_"buttons"] [toggleContentButton "Tour List" showContent ] ] | |
, section_ [class_ $ if showContent then "" else "hidden"] | |
[ table_ [ class_ "table is-striped" ] | |
[ thead_ [] | |
[ tr_ [] | |
[ th_ [] [ text "Name" ] | |
, th_ [] [ text "Countries" ] | |
] | |
] | |
, maybe tourListLoading tourListBody infoIndex | |
] | |
] | |
] | |
where | |
tourListBody tours = tbody_ [] (map (uncurry tourListRow) (M.assocs tours)) | |
tourListRow key Tour{..} = tr_ [onClick (goTourSummary (toMisoString key))] | |
[ td_ [] [text $ toMisoString tourName] | |
, td_ [] [] ] | |
tourListLoading = tbody_ [class_ "loading"] [tr_ [] [td_ [colspan_ "2"] [ text "loading" ]]] | |
tourSummaryView :: MisoString -> Model -> View Action | |
tourSummaryView name m@Model{..} = case M.lookup name infoTour of | |
Just tour -> tourSummaryView' name tour m | |
Nothing -> div_ [class_ "tour-page-index loading"] [text "Loading..."] | |
tourSummaryView' :: MisoString -> Tour -> Model -> View Action | |
tourSummaryView' name Tour{..} m = div_ [class_ "tour-page-index"] | |
[ header_ [] | |
[ h1_ [] [ text (toMisoString tourName) ] | |
, breadcrumbs [ (NoOp, toMisoString tourName) ] | |
, div_ [class_"buttons"] | |
[ p_ [class_ "tour-description"] [ text $ toMisoString tourDescription ] | |
, nav_ [class_ "tour-nav"] | |
[ toggleContentButton "Table" (showContent m) ] | |
, a_ [class_ "button is-link is-outlined", onClick goTourList] | |
(iconButton "arrow-up" "All the tours") | |
] | |
] | |
, section_ [class_ $ "content" <> if showContent m then "" else " hidden"] | |
[tourSummaryTable tourDays] | |
] | |
where | |
tourSummaryTable days = table_ [ class_ "table is-striped" ] | |
[ thead_ [] | |
[ tr_ [] [ th_ [class_ "col-date"] [text "Date"] | |
, th_ [class_ "col-from"] [text "From"] | |
, th_ [class_ "col-to"] [text "To"] | |
, th_ [class_ "col-dist"] [text "Dist (km)"] | |
] | |
] | |
, tbody_ [] (map tourDayRow days) ] | |
tourDayRow TourDay{..} = tr_ [ onClick $ goTourDay name dayDate ] | |
[ td_ [ class_ "col-date" ] [ text $ formatDate dayDate ] | |
, td_ [ class_ "col-from" ] [ text $ toMisoString dayFrom ] | |
, td_ [ class_ "col-to" ] [ text $ toMisoString dayTo ] | |
, td_ [ class_ "col-dist" ] [ text . formatDist $ dayDist ] | |
] | |
formatDist :: Int -> MisoString | |
formatDist 0 = "" | |
formatDist n = toMisoString $ show n | |
formatDate :: Day -> MisoString | |
formatDate = toMisoString . formatTime defaultTimeLocale "%e/%m/%Y" | |
featureName :: Day -> MisoString | |
featureName = toMisoString . formatTime defaultTimeLocale "%Y%m%d" | |
featureDay :: String -> Maybe Day | |
featureDay = parseTimeM True defaultTimeLocale "%Y%m%d" | |
tourDayTitle :: TourDay -> MisoString | |
tourDayTitle TourDay{..} = case (dayFrom, dayTo) of | |
("", "") -> formatDate dayDate | |
(from, "") -> toMisoString from | |
("", to) -> toMisoString to | |
(from, to) -> toMisoString $ from <> " → " <> to | |
breadcrumbs :: [(Action, MisoString)] -> View Action | |
breadcrumbs items = nav_ [ class_ "breadcrumb" ] [ ul_ [] (map (uncurry li) items') ] | |
where | |
items' = ((goTourList, "Tours"):items) | |
li a t = li_ cls [ a_ [onClick a] [text t] ] | |
where cls | a == NoOp = [ class_ "is-active" ] | |
| otherwise = [] | |
tourDayView :: MisoString -> Day -> Model -> View Action | |
tourDayView name date m = case getTourInfo name m of | |
Just tour -> case getTourDay date tour of | |
Just tourDay -> tourDayView' name tour tourDay m | |
Nothing -> div_ [class_ "tour-day"] [text "Not found"] | |
Nothing -> div_ [class_ "tour-day loading"] [text "Loading..."] | |
toggleContentButton :: MisoString -> Bool -> View Action | |
toggleContentButton what showContent = button_ | |
[ class_ "button is-outlined toggle-content", onClick ToggleContent ] | |
(iconButton icon $ label <> " " <> what) | |
where icon | showContent = "minus-square" | |
| otherwise = "plus-square" | |
label | showContent = "Hide" | |
| otherwise = "Show" | |
tourDayView' :: MisoString -> Tour -> TourDay -> Model -> View Action | |
tourDayView' name tour day@TourDay{..} m@Model{..} = div_ [class_ "tour-day"] | |
[ header_ [] | |
[ h1_ [] [ text $ tourDayTitle day ] | |
, breadcrumbs [ (goTourSummary name, toMisoString $ tourName tour) | |
, (NoOp, formatDate dayDate) ] | |
, nav_ [class_"buttons"] | |
((if haveBlog then [toggleContentButton "Blog Post" showContent] else []) | |
++ [tourDayNav name tour day]) | |
] | |
, section_ [class_ $ "blog content" <> if (showContent && mightHaveBlog) then "" else " hidden"] | |
[div_ [class_ "blog-html"] [text "Loading..."]] -- placeholder for html | |
] | |
where | |
blog = isJust <$> M.lookup dayDate blogHtml | |
haveBlog = blog == Just True | |
mightHaveBlog = blog /= Just False | |
tourMap :: Model -> View Action | |
tourMap _ = div_ [class_ "tour-map", id_ "tour-map"] [] | |
elevChart :: Model -> [View Action] | |
elevChart m | routeViewDay (routeView m) == Nothing = [] | |
| otherwise = [canvas_ [ class_ "elev-chart" | |
, id_ "elev-chart" | |
, width_ "640" | |
, height_ "20" | |
] []] | |
iconButton, iconButtonL :: MisoString -> MisoString -> [View Action] | |
iconButton i l = [ span_ [class_ "icon"] [i_ [class_ $ "fa fa-" <> i] []] | |
, span_ [] [text l] ] | |
iconButtonL i = reverse . iconButton i | |
tourDayNav :: MisoString -> Tour -> TourDay -> View Action | |
tourDayNav name tour day = nav_ [class_ "tour-nav"] | |
[ a_ (cls True:attrs prev) | |
(iconButton "arrow-left" "Previous Day") | |
, a_ [ cls False, onClick (goTourSummary name) ] | |
(iconButton "arrow-up" "Tour") | |
, a_ (cls True:attrs next) | |
(iconButtonL "arrow-right" "Next Day ") | |
] | |
where | |
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"] | |
prev = getPrevTourDay tour day | |
next = getNextTourDay tour day | |
getTourDay :: Day -> Tour -> Maybe TourDay | |
getTourDay date = find ((== date) . dayDate) . tourDays | |
getNextTourDay, getPrevTourDay :: Tour -> TourDay -> Maybe TourDay | |
getNextTourDay Tour{tourDays} day = snd <$> find ((== day) . fst) (zip tourDays (tail tourDays)) | |
getPrevTourDay Tour{tourDays} day = snd <$> find ((== day) . fst) (zip (tail tourDays) tourDays) | |
getTourInfo :: MisoString -> Model -> Maybe Tour | |
getTourInfo name m = M.lookup name (infoTour m) | |
tourDayFromTrackName :: MisoString -> MisoString -> Model -> Maybe TourDay | |
tourDayFromTrackName tourName trackName model = do | |
day <- featureDay (fromMisoString trackName) | |
tourDayFromModel tourName day model | |
tourDayFromModel :: MisoString -> Day -> Model -> Maybe TourDay | |
tourDayFromModel name day m = | |
M.lookup name (infoTour m) >>= getTourDay day | |
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 | |
type ClientRoutes = TourSummaryView :<|> TourDayView :<|> TourListView | |
type TourListView = View Action | |
type TourSummaryView = Capture "name" MisoString :> View Action | |
type TourDayView = Capture "name" MisoString :> Capture "date" Day :> View Action | |
-- | Type-safe links used in `onClick` event handlers to route the application | |
goTourList :: Action | |
goTourList = goto tourListView | |
where | |
goto b = ChangeURI (linkURI (safeLink api b)) | |
tourListView = Proxy :: Proxy TourListView | |
api = Proxy :: Proxy ClientRoutes | |
goTourSummary :: MisoString -> Action | |
-- goTourSummary name = FetchInfoTour name | |
goTourSummary name = ChangeURI $ uriTourSummary name | |
goTourDay :: MisoString -> Day -> Action | |
goTourDay name date = ChangeURI $ uriTourDay name date | |
uriTourSummary :: MisoString -> URI | |
uriTourSummary name = linkURI (safeLink api tourSummaryView name) | |
where | |
tourSummaryView = Proxy :: Proxy TourSummaryView | |
api = Proxy :: Proxy ClientRoutes | |
uriTourDay :: MisoString -> Day -> URI | |
uriTourDay name date = linkURI (safeLink api tourDayView name date) | |
where | |
tourDayView = Proxy :: Proxy TourDayView | |
api = Proxy :: Proxy ClientRoutes | |
--linkHref :: URI -> attrs | |
linkHref uri = href_ . toMisoString $ "/" <> show uri | |
-- | 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) |