Skip to content

Instantly share code, notes, and snippets.

@mrkgnao
Created November 12, 2019 17:23
Show Gist options
  • Save mrkgnao/9716c76c9928751558edd5dadfd38cbc to your computer and use it in GitHub Desktop.
Save mrkgnao/9716c76c9928751558edd5dadfd38cbc to your computer and use it in GitHub Desktop.
modified isomorphic miso example for dmjio
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import qualified Common
import Data.Proxy ( Proxy(..) )
import Control.Lens ( (^.), (+=), (-=), (.=), makeLenses )
import qualified Servant.API as S
import Servant.API ( (:<|>)(..) )
import qualified Servant.Links as S
import qualified Miso
import Miso ( View, App(..) )
import qualified Miso.String as Miso
main :: IO ()
main =
Miso.miso $ \currentURI -> App
{ initialAction = Common.NoOp
, model = Common.initialModel currentURI
, update = Miso.fromTransition . updateModel
, view = Common.viewModel
, events = Miso.defaultEvents
, subs = [ Miso.uriSub Common.HandleChangeURI ]
, mountPoint = Nothing
}
updateModel
:: Common.Action
-> Miso.Transition Common.Action Common.Model ()
updateModel action =
case action of
Common.NoOp -> pure ()
Common.AddOne -> Common.counterValue += 1
Common.SubtractOne -> Common.counterValue -= 1
Common.ChangeURI uri ->
Miso.scheduleIO $ do
Miso.pushURI uri
pure Common.NoOp
Common.HandleChangeURI uri -> Common.uri .= uri
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
module Common where
import Control.Lens
import Data.Proxy ( Proxy(..) )
import qualified Servant.API as S
import qualified Servant.Links as S
import Servant.API ( (:<|>)(..), (:>) )
import qualified Miso
import Miso ( View )
import Miso.Html
import qualified Miso.String as Miso
import qualified Network.URI as Network
-- asdf
data Model
= Model
{ _uri :: !Network.URI
, _counterValue :: !Int
}
deriving (Eq, Show)
initialModel :: Network.URI -> Model
initialModel uri =
Model
{ _uri = uri
, _counterValue = 0
}
data Action
= NoOp
| AddOne
| SubtractOne
| ChangeURI !Network.URI
| HandleChangeURI !Network.URI
deriving (Show, Eq)
-- Holds a servant route tree of `View action`
type ViewRoutes = Home :<|> Flipped
-- Home route, contains two buttons and a field
type Home = View Action
-- Flipped route, same as Home, but with the buttons flipped
type Flipped = "flipped" :> View Action
makeLenses ''Model
-- Checks which URI is open and shows the appropriate view
viewModel :: Model -> View Action
viewModel m =
case Miso.runRoute (Proxy @ViewRoutes) viewTree _uri m of
Left _routingError -> page404View
Right v -> v
-- Servant tree of view functions
-- Should follow the structure of ViewRoutes
viewTree
:: (Model -> View Action)
:<|> (Model -> View Action)
viewTree = homeView :<|> flippedView
-- View function of the Home route
homeView :: Model -> View Action
homeView m =
div_ []
[ div_ []
[ text "sdf" -- change this and reload
, text $ Miso.ms $ show $ _uri m
]
, div_
[]
[ button_ [ onClick SubtractOne ] [ text "-" ]
, text $ Miso.ms $ show 5
, button_ [ onClick AddOne ] [ text "+" ]
]
, button_ [ onClick $ ChangeURI flippedLink ] [ text "Go to /flipped" ]
]
-- View function of the Home route
flippedView :: Model -> View Action
flippedView m =
div_ []
[ div_
[]
[ button_ [ onClick AddOne ] [ text "+" ]
, text $ Miso.ms $ show $ _counterValue m
, button_ [ onClick SubtractOne ] [ text "-" ]
]
, button_ [ onClick $ ChangeURI homeLink ] [ text "Go back to /" ]
]
page404View :: View Action
page404View =
text "Yo, 404, page unknown. Go to / or /flipped. Shoo!"
-- Network.URI that points to the home route
homeLink :: Network.URI
homeLink = S.linkURI $ S.safeLink pViewRoutes pHome
-- Network.URI that points to the flipped route
flippedLink :: Network.URI
flippedLink =
S.linkURI $ S.safeLink pViewRoutes (Proxy @Flipped)
pViewRoutes :: Proxy ViewRoutes
pViewRoutes = Proxy
pHome :: Proxy Home
pHome = Proxy
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import qualified Common
import Data.Proxy
import qualified Lucid as L
import qualified Lucid.Base as L
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Wai
import qualified Network.Wai.Middleware.Gzip as Wai
import qualified Network.Wai.Middleware.RequestLogger as Wai
import qualified Servant as S
import Servant ( (:>), (:<|>)(..) )
import qualified System.IO as IO
import qualified Miso
import Database.Beam
import Database.Beam.Postgres
import Database.Beam.Backend.SQL
import qualified Database.Beam.Query.Internal as B
import Data.Pool
port :: Int
port = 3003
main :: IO ()
main = do
IO.hPutStrLn IO.stderr ("Running on port " <> show port <> "...")
Wai.run port $ Wai.logStdout $ compress app
where
compress :: Wai.Middleware
compress = Wai.gzip Wai.def { Wai.gzipFiles = Wai.GzipCompress }
app :: Wai.Application
app =
S.serve (Proxy @ServerAPI)
( static
:<|> serverHandlers
:<|> S.Tagged page404
)
where
static :: S.Server StaticAPI
static = S.serveDirectoryWebApp "server/static"
serverHandlers :: S.Server ServerRoutes
serverHandlers = homeServer :<|> flippedServer
-- Handles the route for the home page, rendering Common.homeView.
homeServer :: S.Server (Miso.ToServerRoutes Common.Home HtmlPage Common.Action)
homeServer =
pure $ HtmlPage $
Common.viewModel $
Common.initialModel Common.homeLink
-- Renders the /flipped page.
flippedServer :: S.Server (Miso.ToServerRoutes Common.Flipped HtmlPage Common.Action)
flippedServer =
pure $ HtmlPage $
Common.viewModel $
Common.initialModel Common.flippedLink
-- The 404 page is a Wai application because the endpoint is Raw.
-- It just renders the page404View and sends it to the client.
page404 :: Wai.Application
page404 _ respond = respond $ Wai.responseLBS
HTTP.status404 [("Content-Type", "text/html")] $
L.renderBS $ L.toHtml Common.page404View
-- | Represents the top level Html code. Its value represents the body of the
-- page.
newtype HtmlPage a = HtmlPage a
deriving (Show, Eq)
instance L.ToHtml a => L.ToHtml (HtmlPage a) where
toHtmlRaw = L.toHtml
toHtml (HtmlPage x) = do
L.doctype_
L.head_ $ do
L.title_ "Unbooru"
L.meta_ [L.charset_ "utf-8"]
L.with (L.script_ mempty)
[ L.makeAttribute "src" "/static/all.js"
, L.makeAttribute "async" mempty
, L.makeAttribute "defer" mempty
]
L.body_ (L.toHtml x)
-- Converts the ClientRoutes (which are a servant tree of routes leading to
-- some `View action`) to lead to `Get '[Html] (HtmlPage (View Common.Action))`
type ServerRoutes
= Miso.ToServerRoutes Common.ViewRoutes HtmlPage Common.Action
-- The server serves static files besides the ServerRoutes, among which is the
-- javascript file of the client.
type ServerAPI =
StaticAPI
:<|> ServerRoutes
:<|> S.Raw -- This will show the 404 page for any unknown route
type StaticAPI = "static" :> S.Raw
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment