From 3e359afcbe99a865ac9c7f435a5cd66a58efb232 Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Tue, 22 Jan 2019 22:40:44 +0200
Subject: [PATCH] Simple routing

---
 frontend/frontend.cabal | 10 ++++--
 frontend/src/Main.hs    | 70 +++++++++++++++++++++++++++++++----------
 2 files changed, 61 insertions(+), 19 deletions(-)

diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal
index a113da2..150705c 100644
--- a/frontend/frontend.cabal
+++ b/frontend/frontend.cabal
@@ -20,9 +20,13 @@ executable frontend
   -- other-modules:
   -- other-extensions:
   build-depends:       base >=4.11 && <4.12
-                     , miso
-                     , jsaddle-warp
-                     , mtl
                      , common
+                     , generic-lens
+                     , jsaddle-warp
+                     , lens
+                     , miso
+                     , mtl
+                     , servant
   hs-source-dirs:      src
   default-language:    Haskell2010
+  ghc-options:         -Wall
diff --git a/frontend/src/Main.hs b/frontend/src/Main.hs
index 57fe622..de90499 100644
--- a/frontend/src/Main.hs
+++ b/frontend/src/Main.hs
@@ -1,41 +1,79 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE ScopedTypeVariables          #-}
 {-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE GADTs              #-}
 module Main where
 
+import           Control.Lens                     (over, set)
 import           Control.Monad.Trans              (liftIO)
+import           Data.Generics.Product
+import           GHC.Generics                     (Generic)
 import           Language.Javascript.JSaddle.Warp
-import           Miso
+import           Miso                             hiding (set)
 import           Miso.String
+import           Servant.API
+import           Servant.Links
+import Data.Proxy (Proxy(..))
+
+type API = Home :<|> Login
+type Home = View Action
+type Login = "login" :> View Action
 
 data Action = Add
             | Subtract
             | SayHello
+            | HandleURI URI
+            | ChangeURI URI
             | NoOp
 
-newtype Model = Model Int deriving (Eq, Num, ToMisoString)
+data Model = Model { counter :: Int
+                   , uri     :: URI }
+  deriving (Eq, Generic)
 
-updateModel :: Action -> Model -> Effect Action Model
-updateModel Add m      = noEff (m + 1)
-updateModel Subtract m = noEff (m - 1)
-updateModel SayHello m = m <# (liftIO (putStrLn "Hello world") >> pure NoOp)
-updateModel NoOp m     = noEff m
+updateModel :: Model -> Action -> Effect Action Model
+updateModel m = \case
+  Add -> noEff (over (field @"counter") (+1) m)
+  Subtract -> noEff (over (field @"counter") (\x -> x - 1) m)
+  SayHello -> m <# (liftIO (putStrLn "Hello world") >> pure NoOp)
+  HandleURI uri -> noEff (set (field @"uri") uri m)
+  ChangeURI uri -> m <# (NoOp <$ pushURI uri)
+  NoOp -> noEff m
 
 viewModel :: Model -> View Action
-viewModel x =
-  div_ [] [ button_  [ onClick Add ] [ text "+" ]
-          , text (ms x)
-          , button_ [ onClick Subtract ] [ text "-" ]
-  ]
+viewModel model = view
+  where
+    view = either (const the404) id $ runRoute @API Proxy handlers uri model
+    handlers = home :<|> login
+    home _ = div_ [] [ button_  [ onClick Add ] [ text "+" ]
+              , text (ms (counter model))
+              , button_ [ onClick Subtract ] [ text "-" ]
+              , button_ [ onClick goLogin ] [ text "go login" ]
+            ]
+    login _ = div_ [] []
+    the404 = div_ [] []
+
+goLogin, goHome :: Action
+goLogin = goto @Login @API Proxy Proxy
+goHome = goto @Home @API Proxy Proxy
+
+goto :: (IsElem endpoint api, HasLink endpoint, MkLink endpoint Link ~ Link) => Proxy api -> Proxy endpoint -> Action
+goto a b = ChangeURI (linkURI (safeLink a b))
 
 main :: IO ()
-main = run 8081 $ startApp App{..}
+main = run 8081 $ do
+  model <- mkModel
+  startApp App{..}
   where
-    model = Model 0
+    mkModel = Model <$> pure 0 <*> getCurrentURI
     initialAction = SayHello
-    update = updateModel
+    update = flip updateModel
     view = viewModel
-    subs = []
+    subs = [ uriSub HandleURI ]
     events = defaultEvents
     mountPoint = Nothing