{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

{- | A very simple site with routes, but based on dynamically changing values

 The current time is computed in the server every second, and the resultant
 generated HTML is automatically updated on the browser. This is only a demo;
 usually we render HTML based on files on disk or something accessible outside
 of the browser. More advanced examples will demonstrate that.
-}
module Ema.Example.Ex02_Clock where

import Control.Concurrent (threadDelay)
import Control.Monad.Logger (logDebugNS, logInfoNS)
import Data.List ((!!))
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Ema
import Ema.Example.Common (tailwindLayout)
import Ema.Route.Generic.TH
import Optics.Core (Prism')
import Text.Blaze.Html5 ((!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A

type Model = UTCTime

data Route
  = Route_Index
  | Route_OnlyTime
  deriving stock (Int -> Route -> ShowS
[Route] -> ShowS
Route -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Route] -> ShowS
$cshowList :: [Route] -> ShowS
show :: Route -> String
$cshow :: Route -> String
showsPrec :: Int -> Route -> ShowS
$cshowsPrec :: Int -> Route -> ShowS
Show, Route -> Route -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Route -> Route -> Bool
$c/= :: Route -> Route -> Bool
== :: Route -> Route -> Bool
$c== :: Route -> Route -> Bool
Eq, Eq Route
Route -> Route -> Bool
Route -> Route -> Ordering
Route -> Route -> Route
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Route -> Route -> Route
$cmin :: Route -> Route -> Route
max :: Route -> Route -> Route
$cmax :: Route -> Route -> Route
>= :: Route -> Route -> Bool
$c>= :: Route -> Route -> Bool
> :: Route -> Route -> Bool
$c> :: Route -> Route -> Bool
<= :: Route -> Route -> Bool
$c<= :: Route -> Route -> Bool
< :: Route -> Route -> Bool
$c< :: Route -> Route -> Bool
compare :: Route -> Route -> Ordering
$ccompare :: Route -> Route -> Ordering
Ord, forall x. Rep Route x -> Route
forall x. Route -> Rep Route x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Route x -> Route
$cfrom :: forall x. Route -> Rep Route x
Generic)

deriveGeneric ''Route
deriveIsRoute ''Route [t|'[WithModel Model]|]

instance EmaSite Route where
  type SiteArg Route = Int -- Delay between clock refresh
  siteInput :: forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action
-> SiteArg Route -> m (Dynamic m (RouteModel Route))
siteInput Some @Type Action
_ SiteArg Route
timerDelay = do
    UTCTime
t0 <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: Type -> Type) a.
(a, (a -> m ()) -> m ()) -> Dynamic m a
Dynamic forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime
t0,) forall a b. (a -> b) -> a -> b
$ \UTCTime -> m ()
setModel -> do
      forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logInfoNS Text
"Ex02" Text
"Starting clock..."
      forall (f :: Type -> Type) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
        forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay SiteArg Route
timerDelay
        UTCTime
t <- forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        forall (m :: Type -> Type). MonadLogger m => Text -> Text -> m ()
logDebugNS Text
"Ex02" Text
"Updating clock..."
        UTCTime -> m ()
setModel UTCTime
t
  siteOutput :: forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
Prism' String Route
-> RouteModel Route -> Route -> m (SiteOutput Route)
siteOutput Prism' String Route
rp RouteModel Route
m Route
r =
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Format -> a -> Asset a
Ema.AssetGenerated Format
Ema.Html forall a b. (a -> b) -> a -> b
$ Prism' String Route -> UTCTime -> Route -> LByteString
render Prism' String Route
rp RouteModel Route
m Route
r

main :: IO ()
main :: IO ()
main = do
  forall (f :: Type -> Type) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall r.
(Show r, Eq r, EmaStaticSite r) =>
SiteArg r -> IO [String]
Ema.runSite @Route Int
delayNormal

delayNormal :: Int
delayNormal :: Int
delayNormal = Int
1000000 -- 1 second

delayFast :: Int
delayFast :: Int
delayFast = Int
10000

render :: Prism' FilePath Route -> UTCTime -> Route -> LByteString
render :: Prism' String Route -> UTCTime -> Route -> LByteString
render Prism' String Route
rp UTCTime
now Route
r =
  Html -> Html -> LByteString
tailwindLayout (Html -> Html
H.title Html
"Clock" forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> Html
H.base forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"/") forall a b. (a -> b) -> a -> b
$
    Html -> Html
H.div forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"container mx-auto" forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.div forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"mt-8 p-2 text-center" forall a b. (a -> b) -> a -> b
$ do
        case Route
r of
          Route
Route_Index ->
            Html
"The current date & time is: "
          Route
Route_OnlyTime ->
            Html
"The current time is: "
        Html -> Html
H.pre forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"text-6xl font-bold mt-2" forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.span forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (AttributeValue
"text-" forall a. Semigroup a => a -> a -> a
<> forall {t} {a}. (FormatTime t, IsString a) => t -> a
randomColor UTCTime
now forall a. Semigroup a => a -> a -> a
<> AttributeValue
"-500") forall a b. (a -> b) -> a -> b
$ do
            let fmt :: String
fmt = case Route
r of
                  Route
Route_Index -> String
"%Y/%m/%d %H:%M:%S%Q"
                  Route
Route_OnlyTime -> String
"%H:%M:%S"
            forall a. ToMarkup a => a -> Html
H.toMarkup forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
fmt UTCTime
now
      Html -> Html
H.div forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"mt-4 text-center" forall a b. (a -> b) -> a -> b
$ do
        case Route
r of
          Route
Route_Index -> do
            Route -> Html -> Html
routeElem Route
Route_OnlyTime Html
"Hide day?"
          Route
Route_OnlyTime -> do
            Route -> Html -> Html
routeElem Route
Route_Index Html
"Show day?"
  where
    routeElem :: Route -> Html -> Html
routeElem Route
r' = Html -> Html
H.a forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"text-xl text-purple-500 hover:underline" forall h. Attributable h => h -> Attribute -> h
! Route -> Attribute
routeHref Route
r'
    routeHref :: Route -> Attribute
routeHref Route
r' =
      AttributeValue -> Attribute
A.href (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString forall a b. (a -> b) -> a -> b
$ forall r. HasCallStack => Prism' String r -> r -> Text
Ema.routeUrl Prism' String Route
rp Route
r')
    randomColor :: t -> a
randomColor t
t =
      let epochSecs :: Int
epochSecs = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe @Int forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s" t
t
          colors :: [a]
colors = [a
"green", a
"gray", a
"purple", a
"red", a
"blue", a
"yellow", a
"black", a
"pink"]
       in [a]
colors forall a. [a] -> Int -> a
!! forall a. Integral a => a -> a -> a
mod Int
epochSecs (forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [a]
colors)