{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-|
Static sites are the opposite of headless applications, they are disembodied.
Shpadoinkle Disembodied is a static site generator for Shpadoinkle applications.
-}
module Shpadoinkle.Disembodied (
-- * Site Reification
Site(..)
-- * Class
, Disembodied(..)
-- * Write Files
, writeSite
) where
import Control.Monad (void)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.Text (unpack)
import Data.Text.IO as T (writeFile)
import Servant.API
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((<.>), (</>))
import UnliftIO.Async (concurrently, forConcurrently_)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Shpadoinkle (Html)
import Shpadoinkle.Backend.Static (renderStatic)
import Shpadoinkle.Router (HTML, View)
-- | The reification of a static site based on Servant routes.
-- Site takes a context `ctx` which is universal for the static site.
-- This is useful for storing commonly used valus like the site name,
-- site url, copyright date, ect.
data Site ctx where
-- | A path segment in the URI
SPath
:: String
-- ^ The current URI path segment
-> Site ctx
-- ^ The site to be rendered at the path
-> Site ctx
-- | Html to be rendered as @index.html@
SIndex
:: forall m a ctx
. (ctx -> Html m a)
-- ^ Given a context, how can we render a page?
-> Site ctx
-- | Capture is the one Servant combinator that can be meaningful in static
-- site generation, and only if we can generate all possible instances.
SCapture
:: (FromHttpApiData x, ToHttpApiData x, Bounded x, Enum x)
=> (x -> Site ctx)
-- ^ Given a context, provide the remaining site to be generated
-> Site ctx
-- | Branch the site at a given point in generation.
SChoice :: Site ctx -> Site ctx -> Site ctx
-- | Type class induction for building the site out of a specification
class Disembodied ctx a where
-- | A type family to represent the relationship between a Servant API
-- and the 'Html' views to render.
--
-- @
-- type SPA m = "about" :> Html m ()
-- :\<|\> Html m ()
--
-- site :: SiteSpec () (SPA m)
-- site = const (h1_ [ text "about" ])
-- :\<|\> const (h1_ [ text "home" ])
-- @
type SiteSpec ctx a :: Type
-- | Construct the site structure out of the associated API
buildSite :: SiteSpec ctx a -> Site ctx
instance (Disembodied ctx x, Disembodied ctx y)
=> Disembodied ctx (x :<|> y) where
type SiteSpec ctx (x :<|> y) = SiteSpec ctx x :<|> SiteSpec ctx y
buildSite :: SiteSpec ctx x :<|> SiteSpec ctx y -> Site ctx
buildSite (x :<|> y) = SChoice (buildSite @ctx @x x) (buildSite @ctx @y y)
{-# INLINABLE buildSite #-}
instance (Disembodied ctx sub, KnownSymbol path)
=> Disembodied ctx (path :> sub) where
type SiteSpec ctx (path :> sub) = SiteSpec ctx sub
buildSite :: SiteSpec ctx sub -> Site ctx
buildSite = SPath (symbolVal (Proxy @path)) . buildSite @ctx @sub
{-# INLINABLE buildSite #-}
instance (Disembodied ctx sub, FromHttpApiData x, ToHttpApiData x, Bounded x, Enum x)
=> Disembodied ctx (Capture sym x :> sub) where
type SiteSpec ctx (Capture sym x :> sub) = x -> SiteSpec ctx sub
buildSite :: (x -> SiteSpec ctx sub) -> Site ctx
buildSite = SCapture . (buildSite @ctx @sub .)
{-# INLINABLE buildSite #-}
instance Disembodied ctx sub
=> Disembodied ctx (QueryParam sym x :> sub) where
type SiteSpec ctx (QueryParam sym x :> sub) = Maybe x -> SiteSpec ctx sub
buildSite :: (Maybe x -> SiteSpec ctx sub) -> Site ctx
buildSite f = buildSite @ctx @sub $ f Nothing
{-# INLINABLE buildSite #-}
instance Disembodied ctx sub
=> Disembodied ctx (QueryParam' ms sym x :> sub) where
type SiteSpec ctx (QueryParam' ms sym x :> sub) = Maybe x -> SiteSpec ctx sub
buildSite :: (Maybe x -> SiteSpec ctx sub) -> Site ctx
buildSite f = buildSite @ctx @sub $ f Nothing
{-# INLINABLE buildSite #-}
instance Disembodied ctx sub
=> Disembodied ctx (QueryParams sym x :> sub) where
type SiteSpec ctx (QueryParams sym x :> sub) = [x] -> SiteSpec ctx sub
buildSite :: ([x] -> SiteSpec ctx sub) -> Site ctx
buildSite f = buildSite @ctx @sub $ f []
{-# INLINABLE buildSite #-}
instance Disembodied ctx sub
=> Disembodied ctx (QueryFlag sym :> sub) where
type SiteSpec ctx (QueryFlag sym :> sub) = Bool -> SiteSpec ctx sub
buildSite :: (Bool -> SiteSpec ctx sub) -> Site ctx
buildSite f = buildSite @ctx @sub $ f False
{-# INLINABLE buildSite #-}
instance Disembodied ctx (f '[HTML] (Html m a)) where
type SiteSpec ctx (f '[HTML] (Html m a)) = ctx -> Html m a
buildSite :: (ctx -> Html m a) -> Site ctx
buildSite = SIndex
{-# INLINABLE buildSite #-}
instance Disembodied ctx (View m a) where
type SiteSpec ctx (View m a) = ctx -> Html m a
buildSite :: (ctx -> Html m a) -> Site ctx
buildSite = SIndex
{-# INLINABLE buildSite #-}
-- | Actually write the site to disk. Branches are written in parallel.
writeSite
:: forall layout ctx. Disembodied ctx layout
=> FilePath
-- ^ Out path
-> ctx
-- ^ Universal context for the static site.
-> SiteSpec ctx layout
-- ^ Specification for the pages of the site relative to a Servant API.
-> IO ()
writeSite fs ctx layout = go fs $ buildSite @ctx @layout layout where
go :: FilePath -> Site ctx -> IO ()
go curr (SIndex page) = T.writeFile (curr </> "index" <.> "html") . renderStatic $ page ctx
go curr (SChoice x y) = void $ go curr x `concurrently` go curr y
go curr (SCapture f) = forConcurrently_ [ minBound .. maxBound ] $
\c -> go curr $ SPath (unpack $ toUrlPiece c) $ f c
go curr (SPath path site) = do
createDirectoryIfMissing False (curr </> path)
go (curr </> path) site