Simple routing

This commit is contained in:
Mats Rauhala 2019-01-22 22:40:44 +02:00
parent ff231322c7
commit 3e359afcbe
2 changed files with 61 additions and 19 deletions

View File

@ -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

View File

@ -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)
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