{-# LANGUAGE DeriveAnyClass #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use impureThrow" #-}

module Ema.Route.Lib.Extra.StaticRoute (
  StaticRoute,
  Model (..),

  -- * Helpers
  staticRouteUrl,
) where

import Control.Exception (throw)
import Control.Monad.Logger (MonadLogger, MonadLoggerIO)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Some (Some)
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Ema
import Ema.CLI qualified
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Optics.Core (Prism', prism')
import System.FilePath (takeExtension, (</>))
import System.UnionMount qualified as UnionMount
import UnliftIO (MonadUnliftIO)

-- | Route to a static file under @baseDir@.
newtype StaticRoute (baseDir :: Symbol) = StaticRoute {forall (baseDir :: Symbol). StaticRoute baseDir -> FilePath
unStaticRoute :: FilePath}
  deriving newtype (StaticRoute baseDir -> StaticRoute baseDir -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Bool
/= :: StaticRoute baseDir -> StaticRoute baseDir -> Bool
$c/= :: forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Bool
== :: StaticRoute baseDir -> StaticRoute baseDir -> Bool
$c== :: forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Bool
Eq, StaticRoute baseDir -> StaticRoute baseDir -> Bool
StaticRoute baseDir -> StaticRoute baseDir -> Ordering
StaticRoute baseDir -> StaticRoute baseDir -> StaticRoute baseDir
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
forall (baseDir :: Symbol). Eq (StaticRoute baseDir)
forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Bool
forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Ordering
forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> StaticRoute baseDir
min :: StaticRoute baseDir -> StaticRoute baseDir -> StaticRoute baseDir
$cmin :: forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> StaticRoute baseDir
max :: StaticRoute baseDir -> StaticRoute baseDir -> StaticRoute baseDir
$cmax :: forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> StaticRoute baseDir
>= :: StaticRoute baseDir -> StaticRoute baseDir -> Bool
$c>= :: forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Bool
> :: StaticRoute baseDir -> StaticRoute baseDir -> Bool
$c> :: forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Bool
<= :: StaticRoute baseDir -> StaticRoute baseDir -> Bool
$c<= :: forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Bool
< :: StaticRoute baseDir -> StaticRoute baseDir -> Bool
$c< :: forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Bool
compare :: StaticRoute baseDir -> StaticRoute baseDir -> Ordering
$ccompare :: forall (baseDir :: Symbol).
StaticRoute baseDir -> StaticRoute baseDir -> Ordering
Ord, Int -> StaticRoute baseDir -> FilePath -> FilePath
[StaticRoute baseDir] -> FilePath -> FilePath
StaticRoute baseDir -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
forall (baseDir :: Symbol).
Int -> StaticRoute baseDir -> FilePath -> FilePath
forall (baseDir :: Symbol).
[StaticRoute baseDir] -> FilePath -> FilePath
forall (baseDir :: Symbol). StaticRoute baseDir -> FilePath
showList :: [StaticRoute baseDir] -> FilePath -> FilePath
$cshowList :: forall (baseDir :: Symbol).
[StaticRoute baseDir] -> FilePath -> FilePath
show :: StaticRoute baseDir -> FilePath
$cshow :: forall (baseDir :: Symbol). StaticRoute baseDir -> FilePath
showsPrec :: Int -> StaticRoute baseDir -> FilePath -> FilePath
$cshowsPrec :: forall (baseDir :: Symbol).
Int -> StaticRoute baseDir -> FilePath -> FilePath
Show)
  deriving stock (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (baseDir :: Symbol) x.
Rep (StaticRoute baseDir) x -> StaticRoute baseDir
forall (baseDir :: Symbol) x.
StaticRoute baseDir -> Rep (StaticRoute baseDir) x
$cto :: forall (baseDir :: Symbol) x.
Rep (StaticRoute baseDir) x -> StaticRoute baseDir
$cfrom :: forall (baseDir :: Symbol) x.
StaticRoute baseDir -> Rep (StaticRoute baseDir) x
Generic)

data Model = Model
  { Model -> Some @Type Action
modelCliAction :: Some Ema.CLI.Action
  , Model -> Map FilePath UTCTime
modelFiles :: Map FilePath UTCTime
  }
  deriving stock (Model -> Model -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Model -> Model -> Bool
$c/= :: Model -> Model -> Bool
== :: Model -> Model -> Bool
$c== :: Model -> Model -> Bool
Eq, Int -> Model -> FilePath -> FilePath
[Model] -> FilePath -> FilePath
Model -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Model] -> FilePath -> FilePath
$cshowList :: [Model] -> FilePath -> FilePath
show :: Model -> FilePath
$cshow :: Model -> FilePath
showsPrec :: Int -> Model -> FilePath -> FilePath
$cshowsPrec :: Int -> Model -> FilePath -> FilePath
Show, forall x. Rep Model x -> Model
forall x. Model -> Rep Model x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Model x -> Model
$cfrom :: forall x. Model -> Rep Model x
Generic)

instance IsRoute (StaticRoute baseDir) where
  type RouteModel (StaticRoute baseDir) = Model
  routePrism :: RouteModel (StaticRoute baseDir)
-> Prism_ FilePath (StaticRoute baseDir)
routePrism (Model -> Map FilePath UTCTime
modelFiles -> Map FilePath UTCTime
files) =
    let enc :: StaticRoute baseDir -> FilePath
enc =
          forall (baseDir :: Symbol). StaticRoute baseDir -> FilePath
unStaticRoute
        dec :: FilePath -> Maybe (StaticRoute baseDir)
dec FilePath
fp =
          forall (baseDir :: Symbol). FilePath -> StaticRoute baseDir
StaticRoute FilePath
fp forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (forall k a. Ord k => k -> Map k a -> Bool
Map.member FilePath
fp Map FilePath UTCTime
files)
     in forall s a. Prism' s a -> Prism_ s a
toPrism_ forall a b. (a -> b) -> a -> b
$ forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall (baseDir :: Symbol). StaticRoute baseDir -> FilePath
enc FilePath -> Maybe (StaticRoute baseDir)
dec
  routeUniverse :: RouteModel (StaticRoute baseDir) -> [StaticRoute baseDir]
routeUniverse (Model -> Map FilePath UTCTime
modelFiles -> Map FilePath UTCTime
files) =
    forall (baseDir :: Symbol). FilePath -> StaticRoute baseDir
StaticRoute forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [k]
Map.keys Map FilePath UTCTime
files

instance KnownSymbol baseDir => EmaSite (StaticRoute baseDir) where
  siteInput :: forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLoggerIO m) =>
Some @Type Action
-> SiteArg (StaticRoute baseDir)
-> m (Dynamic m (RouteModel (StaticRoute baseDir)))
siteInput Some @Type Action
cliAct SiteArg (StaticRoute baseDir)
_ = do
    Dynamic m (Map FilePath UTCTime)
files <- forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLoggerIO m) =>
FilePath -> m (Dynamic m (Map FilePath UTCTime))
staticFilesDynamic forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (forall {k} (t :: k). Proxy @k t
Proxy @baseDir)
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Some @Type Action -> Map FilePath UTCTime -> Model
Model Some @Type Action
cliAct forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic m (Map FilePath UTCTime)
files
  siteOutput :: forall (m :: Type -> Type).
(MonadIO m, MonadLoggerIO m) =>
Prism' FilePath (StaticRoute baseDir)
-> RouteModel (StaticRoute baseDir)
-> StaticRoute baseDir
-> m (SiteOutput (StaticRoute baseDir))
siteOutput Prism' FilePath (StaticRoute baseDir)
_ RouteModel (StaticRoute baseDir)
_ (StaticRoute FilePath
path) =
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> Asset a
Ema.AssetStatic forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> FilePath
symbolVal (forall {k} (t :: k). Proxy @k t
Proxy @baseDir) FilePath -> FilePath -> FilePath
</> FilePath
path

staticFilesDynamic ::
  forall m.
  (MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLoggerIO m) =>
  FilePath ->
  m (Dynamic m (Map FilePath UTCTime))
staticFilesDynamic :: forall (m :: Type -> Type).
(MonadIO m, MonadUnliftIO m, MonadLogger m, MonadLoggerIO m) =>
FilePath -> m (Dynamic m (Map FilePath UTCTime))
staticFilesDynamic FilePath
baseDir = do
  let pats :: [((), FilePath)]
pats = [((), FilePath
"**")]
      ignorePats :: [FilePath]
ignorePats = [FilePath
".*"]
      model0 :: Map FilePath UTCTime
model0 = forall a. Monoid a => a
mempty
  forall (m :: Type -> Type) a.
(a, (a -> m ()) -> m ()) -> Dynamic m a
Dynamic forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall model (m :: Type -> Type) b.
(MonadIO m, MonadUnliftIO m, MonadLogger m, Show b, Ord b) =>
FilePath
-> [(b, FilePath)]
-> [FilePath]
-> model
-> (b -> FilePath -> FileAction () -> m (model -> model))
-> m (model, (model -> m ()) -> m ())
UnionMount.mount FilePath
baseDir [((), FilePath)]
pats [FilePath]
ignorePats Map FilePath UTCTime
model0 (forall a b. a -> b -> a
const FilePath
-> FileAction ()
-> m (Map FilePath UTCTime -> Map FilePath UTCTime)
handleUpdate)
  where
    handleUpdate ::
      FilePath ->
      UnionMount.FileAction () ->
      m (Map FilePath UTCTime -> Map FilePath UTCTime)
    handleUpdate :: FilePath
-> FileAction ()
-> m (Map FilePath UTCTime -> Map FilePath UTCTime)
handleUpdate FilePath
fp = \case
      UnionMount.Refresh RefreshAction
_ ()
_ -> do
        UTCTime
lastAccessed <- 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 a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
fp UTCTime
lastAccessed
      FileAction ()
UnionMount.Delete -> do
        forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete FilePath
fp

-- | Like `Ema.routeUrl`, but looks up the value and appends it to URL in live-server (for force-reload in browser)
staticRouteUrl ::
  forall s baseDir.
  (IsString s, HasCallStack) =>
  Prism' FilePath (StaticRoute baseDir) ->
  RouteModel (StaticRoute baseDir) ->
  FilePath ->
  s
staticRouteUrl :: forall s (baseDir :: Symbol).
(IsString s, HasCallStack) =>
Prism' FilePath (StaticRoute baseDir)
-> RouteModel (StaticRoute baseDir) -> FilePath -> s
staticRouteUrl Prism' FilePath (StaticRoute baseDir)
rp RouteModel (StaticRoute baseDir)
model FilePath
fp =
  let lastAccessed :: UTCTime
lastAccessed = FilePath -> Model -> UTCTime
lookupMust FilePath
fp RouteModel (StaticRoute baseDir)
model
      tag :: Text
tag = forall a. ToText a => a -> Text
toText forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%s" UTCTime
lastAccessed
      url :: Text
url = forall r. HasCallStack => Prism' FilePath r -> r -> Text
Ema.routeUrl Prism' FilePath (StaticRoute baseDir)
rp forall a b. (a -> b) -> a -> b
$ forall (baseDir :: Symbol). FilePath -> StaticRoute baseDir
StaticRoute FilePath
fp
   in forall a. IsString a => FilePath -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> FilePath
toString forall a b. (a -> b) -> a -> b
$ Text
url forall a. Semigroup a => a -> a -> a
<> Text -> Text
refreshAddendum Text
tag
  where
    -- Force the browser to reload the static file referenced
    refreshAddendum :: Text -> Text
refreshAddendum Text
tag =
      forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ do
        -- In live server, force reload all (re-added/modified) static files.
        -- In statically generated site, do it only for CSS and JS files.
        forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$
          Some @Type Action -> Bool
Ema.CLI.isLiveServer (Model -> Some @Type Action
modelCliAction RouteModel (StaticRoute baseDir)
model)
            Bool -> Bool -> Bool
|| FilePath -> FilePath
takeExtension FilePath
fp forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`List.elem` [FilePath
".css", FilePath
".js"]
        forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text
"?" forall a. Semigroup a => a -> a -> a
<> Text
tag

lookupMust :: FilePath -> Model -> UTCTime
lookupMust :: FilePath -> Model -> UTCTime
lookupMust FilePath
fp Model
model =
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
fp (Model -> Map FilePath UTCTime
modelFiles Model
model) of
    Just UTCTime
lastAccessed -> UTCTime
lastAccessed
    Maybe UTCTime
Nothing -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ FilePath -> MissingStaticFile
MissingStaticFile FilePath
fp

newtype MissingStaticFile = MissingStaticFile FilePath
  deriving stock (MissingStaticFile -> MissingStaticFile -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MissingStaticFile -> MissingStaticFile -> Bool
$c/= :: MissingStaticFile -> MissingStaticFile -> Bool
== :: MissingStaticFile -> MissingStaticFile -> Bool
$c== :: MissingStaticFile -> MissingStaticFile -> Bool
Eq, Int -> MissingStaticFile -> FilePath -> FilePath
[MissingStaticFile] -> FilePath -> FilePath
MissingStaticFile -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [MissingStaticFile] -> FilePath -> FilePath
$cshowList :: [MissingStaticFile] -> FilePath -> FilePath
show :: MissingStaticFile -> FilePath
$cshow :: MissingStaticFile -> FilePath
showsPrec :: Int -> MissingStaticFile -> FilePath -> FilePath
$cshowsPrec :: Int -> MissingStaticFile -> FilePath -> FilePath
Show)
  deriving anyclass (Show MissingStaticFile
Typeable @Type MissingStaticFile
SomeException -> Maybe MissingStaticFile
MissingStaticFile -> FilePath
MissingStaticFile -> SomeException
forall e.
Typeable @Type e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> FilePath)
-> Exception e
displayException :: MissingStaticFile -> FilePath
$cdisplayException :: MissingStaticFile -> FilePath
fromException :: SomeException -> Maybe MissingStaticFile
$cfromException :: SomeException -> Maybe MissingStaticFile
toException :: MissingStaticFile -> SomeException
$ctoException :: MissingStaticFile -> SomeException
Exception)