{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | 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.Ex03_Clock where

import Control.Concurrent (threadDelay)
import qualified Data.LVar as LVar
import Data.List ((!!))
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Ema (Ema (..))
import qualified Ema
import qualified Ema.CLI
import qualified Ema.Helper.Tailwind as Tailwind
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

data Route
  = Index
  | OnlyTime
  deriving (Int -> Route -> ShowS
[Route] -> ShowS
Route -> String
(Int -> Route -> ShowS)
-> (Route -> String) -> ([Route] -> ShowS) -> Show Route
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, Int -> Route
Route -> Int
Route -> [Route]
Route -> Route
Route -> Route -> [Route]
Route -> Route -> Route -> [Route]
(Route -> Route)
-> (Route -> Route)
-> (Int -> Route)
-> (Route -> Int)
-> (Route -> [Route])
-> (Route -> Route -> [Route])
-> (Route -> Route -> [Route])
-> (Route -> Route -> Route -> [Route])
-> Enum Route
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Route -> Route -> Route -> [Route]
$cenumFromThenTo :: Route -> Route -> Route -> [Route]
enumFromTo :: Route -> Route -> [Route]
$cenumFromTo :: Route -> Route -> [Route]
enumFromThen :: Route -> Route -> [Route]
$cenumFromThen :: Route -> Route -> [Route]
enumFrom :: Route -> [Route]
$cenumFrom :: Route -> [Route]
fromEnum :: Route -> Int
$cfromEnum :: Route -> Int
toEnum :: Int -> Route
$ctoEnum :: Int -> Route
pred :: Route -> Route
$cpred :: Route -> Route
succ :: Route -> Route
$csucc :: Route -> Route
Enum, Route
Route -> Route -> Bounded Route
forall a. a -> a -> Bounded a
maxBound :: Route
$cmaxBound :: Route
minBound :: Route
$cminBound :: Route
Bounded)

instance Ema UTCTime Route where
  encodeRoute :: UTCTime -> Route -> String
encodeRoute UTCTime
_time = \case
    Route
Index -> String
"index.html"
    Route
OnlyTime -> String
"time.html"
  decodeRoute :: UTCTime -> String -> Maybe Route
decodeRoute UTCTime
_time = \case
    String
"index.html" -> Route -> Maybe Route
forall a. a -> Maybe a
Just Route
Index
    String
"time.html" -> Route -> Maybe Route
forall a. a -> Maybe a
Just Route
OnlyTime
    String
_ -> Maybe Route
forall a. Maybe a
Nothing

main :: IO ()
main :: IO ()
main = do
  (Action -> UTCTime -> Route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar UTCTime -> m ())
-> IO ()
forall model route.
(Ema model route, Show route) =>
(Action -> model -> route -> Asset LByteString)
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar model -> m ())
-> IO ()
Ema.runEma (\Action
act UTCTime
m -> Format -> LByteString -> Asset LByteString
forall a. Format -> a -> Asset a
Ema.AssetGenerated Format
Ema.Html (LByteString -> Asset LByteString)
-> (Route -> LByteString) -> Route -> Asset LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> UTCTime -> Route -> LByteString
render Action
act UTCTime
m) ((forall (m :: * -> *).
  (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
  Action -> LVar UTCTime -> m ())
 -> IO ())
-> (forall (m :: * -> *).
    (MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
    Action -> LVar UTCTime -> m ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Action
_act LVar UTCTime
model ->
    m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      -- logDebugNS "ex:clock" "Refreshing time"
      LVar UTCTime -> UTCTime -> m ()
forall (m :: * -> *) a. MonadIO m => LVar a -> a -> m ()
LVar.set LVar UTCTime
model (UTCTime -> m ()) -> m UTCTime -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000

render :: Ema.CLI.Action -> UTCTime -> Route -> LByteString
render :: Action -> UTCTime -> Route -> LByteString
render Action
emaAction UTCTime
now Route
r =
  Action -> Html -> Html -> LByteString
Tailwind.layout Action
emaAction (Html -> Html
H.title Html
"Clock" Html -> Html -> Html
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Html
H.base Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"/") (Html -> LByteString) -> Html -> LByteString
forall a b. (a -> b) -> a -> b
$
    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"container mx-auto" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"mt-8 p-2 text-center" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        case Route
r of
          Route
Index ->
            Html
"The current date & time is: "
          Route
OnlyTime ->
            Html
"The current time is: "
        Html -> Html
H.pre (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"text-6xl font-bold mt-2" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.span (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (AttributeValue
"text-" AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> UTCTime -> AttributeValue
forall a t. (IsString a, FormatTime t) => t -> a
randomColor UTCTime
now AttributeValue -> AttributeValue -> AttributeValue
forall a. Semigroup a => a -> a -> a
<> AttributeValue
"-500") (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
            let fmt :: String
fmt = case Route
r of
                  Route
Index -> String
"%Y/%m/%d %H:%M:%S"
                  Route
OnlyTime -> String
"%H:%M:%S"
            String -> Html
forall a. ToMarkup a => a -> Html
H.toMarkup (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
fmt UTCTime
now
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"mt-4 text-center" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        case Route
r of
          Route
Index -> do
            Route -> Html -> Html
forall r. Ema UTCTime r => r -> Html -> Html
routeElem Route
OnlyTime Html
"Hide day?"
          Route
OnlyTime -> do
            Route -> Html -> Html
forall r. Ema UTCTime r => r -> Html -> Html
routeElem Route
Index Html
"Show day?"
  where
    routeElem :: r -> Html -> Html
routeElem r
r' Html
w =
      Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"text-xl text-purple-500 hover:underline" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! r -> Attribute
forall r. Ema UTCTime r => r -> Attribute
routeHref r
r' (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
w
    routeHref :: r -> Attribute
routeHref r
r' =
      AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue)
-> (Text -> String) -> Text -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ UTCTime -> r -> Text
forall r model. Ema model r => model -> r -> Text
Ema.routeUrl UTCTime
now r
r')
    randomColor :: t -> a
randomColor t
t =
      let epochSecs :: Int
epochSecs = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> (String -> Maybe Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Read Int => String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe @Int (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> t -> String
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 [a] -> Int -> a
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
epochSecs ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
colors)