{-# LANGUAGE DeriveAnyClass #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use impureThrow" #-}
module Ema.Route.Lib.Extra.StaticRoute (
StaticRoute,
Model (..),
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)
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
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
refreshAddendum :: Text -> Text
refreshAddendum Text
tag =
forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ do
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)