-- | Generates the site's static files (robots.txt, funding.json, …) from @website.yaml@
module MathiasSM.Rules.Static (processStaticFiles) where

import Data.List (intercalate)
import Hakyll (
    Compiler,
    Rules,
    compile,
    create,
    fromFilePath,
    idRoute,
    load,
    makeItem,
    route,
 )
import MathiasSM.Config (SiteConfig, baseUrl, siteAuthor, siteName, socialsFile)
import MathiasSM.Content (requireSocials)
import MathiasSM.Yaml.Social (Social (..))
import MathiasSM.Yaml.Website (
    Contact (..),
    Funding (..),
    FundingChannel (..),
    FundingEntity (..),
    FundingPlan (..),
    FundingProject (..),
    Manifest (..),
    Robots (..),
    Security (..),
    Trust (..),
    Website (..),
 )

-- | Emits the files that the site generates from @website.yaml@ (rather than copies)
processStaticFiles :: SiteConfig -> Website -> Rules ()
processStaticFiles :: SiteConfig -> Website -> Rules ()
processStaticFiles SiteConfig
cfg Website
website = do
    let url :: [Char]
url = SiteConfig -> [Char]
baseUrl SiteConfig
cfg
        contact :: Contact
contact = Website -> Contact
websiteContact Website
website
    [Char] -> [Char] -> Rules ()
createFile [Char]
"robots.txt" ([Char] -> [[Char]] -> [Char]
robotsTxt [Char]
url (Robots -> [[Char]]
robotsDisallow (Website -> Robots
websiteRobots Website
website)))
    [Char] -> [Char] -> Rules ()
createFile [Char]
"manifest.webmanifest" ([Char] -> Manifest -> [Char]
manifestTxt (SiteConfig -> [Char]
siteName SiteConfig
cfg) (Website -> Manifest
websiteManifest Website
website))
    [Char] -> [Char] -> Rules ()
createFile [Char]
".well-known/security.txt" ([Char] -> [Char] -> Security -> [Char]
securityTxt [Char]
url (Contact -> [Char]
contactPage Contact
contact) (Website -> Security
websiteSecurity Website
website))
    [Char] -> [Char] -> Rules ()
createFile [Char]
".well-known/funding-manifest-urls" ([Char] -> [Char]
fundingManifestUrls [Char]
url)
    [Char] -> [Char] -> Rules ()
createFile [Char]
"funding.json" ([Char] -> [Char] -> Funding -> [Char]
fundingJson (SiteConfig -> [Char]
siteAuthor SiteConfig
cfg) [Char]
url (Website -> Funding
websiteFunding Website
website))
    [Char] -> Compiler [Char] -> Rules ()
createFileCompiler [Char]
".well-known/trust.txt" (Compiler [Char] -> Rules ()) -> Compiler [Char] -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
        socials <- SiteConfig -> Compiler [[Char]]
socialHrefs SiteConfig
cfg
        pure (trustTxt url (contactPage contact) socials (websiteTrust website))

-- | Creates a routed file whose content is already known
createFile :: FilePath -> String -> Rules ()
createFile :: [Char] -> [Char] -> Rules ()
createFile [Char]
path [Char]
content = [Identifier] -> Rules () -> Rules ()
create [[Char] -> Identifier
fromFilePath [Char]
path] (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
    Routes -> Rules ()
route Routes
idRoute
    Compiler (Item [Char]) -> Rules ()
forall a.
(Binary a, Typeable a, Writable a) =>
Compiler (Item a) -> Rules ()
compile (Compiler (Item [Char]) -> Rules ())
-> Compiler (Item [Char]) -> Rules ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Compiler (Item [Char])
forall a. a -> Compiler (Item a)
makeItem [Char]
content

-- | Creates a routed file whose content is computed in a 'Compiler'
createFileCompiler :: FilePath -> Compiler String -> Rules ()
createFileCompiler :: [Char] -> Compiler [Char] -> Rules ()
createFileCompiler [Char]
path Compiler [Char]
build = [Identifier] -> Rules () -> Rules ()
create [[Char] -> Identifier
fromFilePath [Char]
path] (Rules () -> Rules ()) -> Rules () -> Rules ()
forall a b. (a -> b) -> a -> b
$ do
    Routes -> Rules ()
route Routes
idRoute
    Compiler (Item [Char]) -> Rules ()
forall a.
(Binary a, Typeable a, Writable a) =>
Compiler (Item a) -> Rules ()
compile (Compiler [Char]
build Compiler [Char]
-> ([Char] -> Compiler (Item [Char])) -> Compiler (Item [Char])
forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Compiler (Item [Char])
forall a. a -> Compiler (Item a)
makeItem)

-- | The @href@ of every social account, in file order
socialHrefs :: SiteConfig -> Compiler [String]
socialHrefs :: SiteConfig -> Compiler [[Char]]
socialHrefs SiteConfig
cfg = do
    file <- Identifier -> Compiler (Item [Char])
forall a. (Binary a, Typeable a) => Identifier -> Compiler (Item a)
load (SiteConfig -> Identifier
socialsFile SiteConfig
cfg)
    socials <- requireSocials file
    pure (map socialHref socials)

-- Text files ----------------------------------------------------------------

robotsTxt :: String -> [String] -> String
robotsTxt :: [Char] -> [[Char]] -> [Char]
robotsTxt [Char]
url [[Char]]
disallow =
    [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
        [[Char]
"User-Agent: *", [Char]
""]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"Disallow: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) [[Char]]
disallow
            [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"", [Char]
"Sitemap: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/sitemap.xml"]

securityTxt :: String -> String -> Security -> String
securityTxt :: [Char] -> [Char] -> Security -> [Char]
securityTxt [Char]
url [Char]
contactPage Security
security =
    [[Char]] -> [Char]
unlines
        [ [Char]
"# https://www.rfc-editor.org/rfc/rfc9116"
        , [Char]
""
        , [Char]
"Canonical: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/.well-known/security.txt"
        , [Char]
""
        , [Char]
"Contact: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
contactPage
        , [Char]
""
        , [Char]
"Preferred-Languages: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Security -> [Char]
securityPreferredLanguages Security
security
        , [Char]
""
        , [Char]
"Expires: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Security -> [Char]
securityExpires Security
security
        ]

fundingManifestUrls :: String -> String
fundingManifestUrls :: [Char] -> [Char]
fundingManifestUrls [Char]
url = [Char]
url [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/funding.json\n"

trustTxt :: String -> String -> [String] -> Trust -> String
trustTxt :: [Char] -> [Char] -> [[Char]] -> Trust -> [Char]
trustTxt [Char]
url [Char]
contactPage [[Char]]
socials Trust
trust =
    [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
        [ [Char]
"# https://journallist.net/reference-document-for-trust-txt-specifications"
        , [Char]
""
        , [Char]
"# Single member: me."
        , [Char]
"member=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
url
        , [Char]
"contact=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
url [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
contactPage
        , [Char]
""
        , [Char]
"# My socials:"
        ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"social=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) [[Char]]
socials
            [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"", [Char]
"", [Char]
"# AI, begone (please):", [Char]
"datatrainingallowed=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Trust -> [Char]
trustTrainingAllowed Trust
trust]

-- JSON files ----------------------------------------------------------------

manifestTxt :: String -> Manifest -> String
manifestTxt :: [Char] -> Manifest -> [Char]
manifestTxt [Char]
name Manifest
manifest =
    Json -> [Char]
encodePretty
        ( [([Char], Json)] -> Json
JObject
            [ ([Char]
"name", [Char] -> Json
JString [Char]
name)
            , ([Char]
"background_color", [Char] -> Json
JString (Manifest -> [Char]
manifestBackgroundColor Manifest
manifest))
            , ([Char]
"theme_color", [Char] -> Json
JString (Manifest -> [Char]
manifestThemeColor Manifest
manifest))
            ,
                ( [Char]
"icons"
                , [Json] -> Json
JArray
                    [ [([Char], Json)] -> Json
JObject [([Char]
"src", [Char] -> Json
JString [Char]
"/favicon-192.png"), ([Char]
"type", [Char] -> Json
JString [Char]
"image/png"), ([Char]
"sizes", [Char] -> Json
JString [Char]
"192x192")]
                    , [([Char], Json)] -> Json
JObject [([Char]
"src", [Char] -> Json
JString [Char]
"/favicon-512.png"), ([Char]
"type", [Char] -> Json
JString [Char]
"image/png"), ([Char]
"sizes", [Char] -> Json
JString [Char]
"512x512")]
                    ]
                )
            ]
        )
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

fundingJson :: String -> String -> Funding -> String
fundingJson :: [Char] -> [Char] -> Funding -> [Char]
fundingJson [Char]
author [Char]
url Funding
funding =
    Json -> [Char]
encodePretty
        ( [([Char], Json)] -> Json
JObject
            [ ([Char]
"version", [Char] -> Json
JString [Char]
"v1.0.0")
            ,
                ( [Char]
"entity"
                , [([Char], Json)] -> Json
JObject
                    [ ([Char]
"type", [Char] -> Json
JString [Char]
"individual")
                    , ([Char]
"role", [Char] -> Json
JString [Char]
"owner")
                    , ([Char]
"name", [Char] -> Json
JString [Char]
author)
                    , ([Char]
"email", [Char] -> Json
JString (FundingEntity -> [Char]
fundingEntityEmail (Funding -> FundingEntity
fundingEntity Funding
funding)))
                    , ([Char]
"phone", [Char] -> Json
JString [Char]
"")
                    , ([Char]
"description", [Char] -> Json
JString (FundingEntity -> [Char]
fundingEntityDescription (Funding -> FundingEntity
fundingEntity Funding
funding)))
                    , ([Char]
"webpageUrl", [([Char], Json)] -> Json
JObject [([Char]
"url", [Char] -> Json
JString [Char]
url)])
                    ]
                )
            , ([Char]
"projects", [Json] -> Json
JArray ((FundingProject -> Json) -> [FundingProject] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> FundingProject -> Json
projectJson [Char]
url) (Funding -> [FundingProject]
fundingProjects Funding
funding)))
            ,
                ( [Char]
"funding"
                , [([Char], Json)] -> Json
JObject
                    [ ([Char]
"channels", [Json] -> Json
JArray ((FundingChannel -> Json) -> [FundingChannel] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map FundingChannel -> Json
channelJson (Funding -> [FundingChannel]
fundingChannels Funding
funding)))
                    , ([Char]
"plans", [Json] -> Json
JArray ((FundingPlan -> Json) -> [FundingPlan] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map FundingPlan -> Json
planJson (Funding -> [FundingPlan]
fundingPlans Funding
funding)))
                    , ([Char]
"history", [Json] -> Json
JArray [])
                    ]
                )
            ]
        )
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"

projectJson :: String -> FundingProject -> Json
projectJson :: [Char] -> FundingProject -> Json
projectJson [Char]
url FundingProject
project =
    [([Char], Json)] -> Json
JObject
        [ ([Char]
"guid", [Char] -> Json
JString (FundingProject -> [Char]
fundingProjectGuid FundingProject
project))
        , ([Char]
"name", [Char] -> Json
JString (FundingProject -> [Char]
fundingProjectName FundingProject
project))
        , ([Char]
"description", [Char] -> Json
JString (FundingProject -> [Char]
fundingProjectDescription FundingProject
project))
        , ([Char]
"webpageUrl", [([Char], Json)] -> Json
JObject [([Char]
"url", [Char] -> Json
JString [Char]
url)])
        ,
            ( [Char]
"repositoryUrl"
            , [([Char], Json)] -> Json
JObject
                [ ([Char]
"url", [Char] -> Json
JString (FundingProject -> [Char]
fundingProjectRepositoryUrl FundingProject
project))
                , ([Char]
"wellKnown", [Char] -> Json
JString (FundingProject -> [Char]
fundingProjectRepositoryWellKnown FundingProject
project))
                ]
            )
        , ([Char]
"licenses", [Json] -> Json
JArray (([Char] -> Json) -> [[Char]] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Json
JString (FundingProject -> [[Char]]
fundingProjectLicenses FundingProject
project)))
        , ([Char]
"tags", [Json] -> Json
JArray (([Char] -> Json) -> [[Char]] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Json
JString (FundingProject -> [[Char]]
fundingProjectTags FundingProject
project)))
        ]

channelJson :: FundingChannel -> Json
channelJson :: FundingChannel -> Json
channelJson FundingChannel
channel =
    [([Char], Json)] -> Json
JObject
        [ ([Char]
"guid", [Char] -> Json
JString (FundingChannel -> [Char]
fundingChannelGuid FundingChannel
channel))
        , ([Char]
"type", [Char] -> Json
JString (FundingChannel -> [Char]
fundingChannelType FundingChannel
channel))
        , ([Char]
"address", [Char] -> Json
JString (FundingChannel -> [Char]
fundingChannelAddress FundingChannel
channel))
        , ([Char]
"description", [Char] -> Json
JString (FundingChannel -> [Char]
fundingChannelDescription FundingChannel
channel))
        ]

planJson :: FundingPlan -> Json
planJson :: FundingPlan -> Json
planJson FundingPlan
plan =
    [([Char], Json)] -> Json
JObject
        [ ([Char]
"guid", [Char] -> Json
JString (FundingPlan -> [Char]
fundingPlanGuid FundingPlan
plan))
        , ([Char]
"status", [Char] -> Json
JString (FundingPlan -> [Char]
fundingPlanStatus FundingPlan
plan))
        , ([Char]
"name", [Char] -> Json
JString (FundingPlan -> [Char]
fundingPlanName FundingPlan
plan))
        , ([Char]
"description", [Char] -> Json
JString (FundingPlan -> [Char]
fundingPlanDescription FundingPlan
plan))
        , ([Char]
"amount", Int -> Json
JNumber (FundingPlan -> Int
fundingPlanAmount FundingPlan
plan))
        , ([Char]
"currency", [Char] -> Json
JString (FundingPlan -> [Char]
fundingPlanCurrency FundingPlan
plan))
        , ([Char]
"frequency", [Char] -> Json
JString (FundingPlan -> [Char]
fundingPlanFrequency FundingPlan
plan))
        , ([Char]
"channels", [Json] -> Json
JArray (([Char] -> Json) -> [[Char]] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Json
JString (FundingPlan -> [[Char]]
fundingPlanChannels FundingPlan
plan)))
        ]

-- | A tiny JSON value with stable key order, rendered with 2-space indentation
data Json
    = JObject [(String, Json)]
    | JArray [Json]
    | JString String
    | JNumber Int

encodePretty :: Json -> String
encodePretty :: Json -> [Char]
encodePretty = Int -> Json -> [Char]
go Int
0
  where
    indent :: Int -> [Char]
indent Int
n = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [Char] -> [[Char]]
forall a. Int -> a -> [a]
replicate Int
n [Char]
"  ")

    go :: Int -> Json -> String
    go :: Int -> Json -> [Char]
go Int
_ (JString [Char]
s) = [Char]
"\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
escape [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\""
    go Int
_ (JNumber Int
i) = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
    go Int
_ (JArray []) = [Char]
"[]"
    go Int
n (JArray [Json]
xs) =
        [Char]
"["
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
indent (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Json -> [Char]
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Json
x | Json
x <- [Json]
xs]
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
indent Int
n
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
    go Int
_ (JObject []) = [Char]
"{}"
    go Int
n (JObject [([Char], Json)]
fields) =
        [Char]
"{"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
indent (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
key [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Json -> [Char]
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Json
value | ([Char]
key, Json
value) <- [([Char], Json)]
fields]
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
indent Int
n
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}"

    escape :: [Char] -> [Char]
escape = (Char -> [Char]) -> [Char] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char -> [Char]) -> [Char] -> [Char])
-> (Char -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ \Char
char -> case Char
char of
        Char
'"' -> [Char]
"\\\""
        Char
'\\' -> [Char]
"\\\\"
        Char
'\n' -> [Char]
"\\n"
        Char
other -> [Char
other]