<commit_before>{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, TemplateHaskell #-}
{-# LANGUAGE TypeOperators, TypeFamilies, DataKinds, TupleSections #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}

module Sweetroll.Api where

import           Sweetroll.Prelude hiding (Context)
import           Data.Maybe (fromJust)
import qualified Data.HashMap.Strict as HMS
import           Data.FileEmbed
import           Data.Microformats2.Parser.HtmlUtil (getInnerHtml)
import qualified Text.HTML.DOM as HTML
import           Text.XML (documentRoot)
import           Text.Pandoc
import           Text.Highlighting.Kate.Format.HTML (styleToCss)
import qualified Network.HTTP.Link as L
import           Network.Wai
import           Network.Wai.UrlMap
import           Network.Wai.Middleware.AcceptOverride
import           Network.Wai.Middleware.Autohead
import           Network.Wai.Middleware.Cors
import           Network.Wai.Middleware.Throttle
import           Network.Wai.Application.Static
import           Servant
import           Gitson
import           Gitson.Util (maybeReadIntString)
import           Sweetroll.Conf
import           Sweetroll.Monads
import           Sweetroll.Routes
import           Sweetroll.Pages
import           Sweetroll.Slice
import           Sweetroll.Rendering
import           Sweetroll.Auth
import           Sweetroll.Micropub.Endpoint
import           Sweetroll.Webmention.Receive
import           Sweetroll.Proxy

getIndieConfig ∷ Sweetroll IndieConfig
getIndieConfig = getConfOpt indieConfig

getBaseCss ∷ Sweetroll LByteString
getBaseCss = return $ pandocCss ++ sanitizeCss ++ opentypeCss
  where pandocCss = cs . styleToCss . writerHighlightStyle $ pandocWriterOptions
        sanitizeCss = cs $(embedFile "bower_components/sanitize-css/sanitize.css")
        opentypeCss = cs $(embedFile "bower_components/normalize-opentype.css/normalize-opentype.css")

getDefaultCss ∷ Sweetroll LByteString
getDefaultCss = return $ cs $(embedFile "style.css")

getDefaultIcons ∷ Sweetroll LByteString
getDefaultIcons = return $ cs $(embedFile "icons.svg")

getIndex ∷ Sweetroll (WithLink (View IndexedPage))
getIndex = do
  ipp ← getConfOpt itemsPerPage
  catNames ← getConfOpt categoriesInLanding
  (slices, entries0) ← foldM (\(slices, entries) catName →
                               readCategory ipp Nothing Nothing entries catName >>= \(slices', entries') → return (slices ++ slices', entries'))
                             ([], HMS.empty)
                             catNames
  entries ← postprocessEntries entries0
  selfLink ← genLink "self" $ permalink (Proxy ∷ Proxy IndexRoute)
  addLinks [selfLink] $ mkView $ IndexedPage catNames slices entries

getCat ∷ String → Maybe Int → Maybe Int → Sweetroll (WithLink (View IndexedPage))
getCat catName before after = do
  ipp ← getConfOpt itemsPerPage
  (slice : slices, entries0) ← readCategory ipp before after HMS.empty catName
  entries ← postprocessEntries entries0
  guardBoolM (renderError err404 "404") (not $ null $ sliceItems slice)
  selfLink ← genLink "self" $ catLink slice
  addLinks [selfLink] $ mkView $ IndexedPage [catName] (slice : slices) entries

getEntry ∷ String → String → Sweetroll (WithLink (View EntryPage))
getEntry catName slug = do
  entry ← postprocessEntry =<< (guardJustM (notFoundOrGone catName slug) $ readDocumentByName catName slug)
  -- TODO: cacheHTTPDate -- don't forget responses' dates! -- 204 will be thrown before rendering!
  otherSlugs ← listDocumentKeys catName
  selfLink ← genLink "self" $ permalink (Proxy ∷ Proxy EntryRoute) catName slug
  addLinks [selfLink] $ mkView $ EntryPage catName (map readSlug $ sort otherSlugs) (slug, entry)

postprocessEntries ∷ HashMap α Value → Sweetroll (HashMap α Value)
postprocessEntries = mapM postprocessEntry

postprocessEntry ∷ Value → Sweetroll Value
postprocessEntry entry = do
  secs ← getSecs
  conf ← getConf
  let proxifyLink s = proxiedUri secs s
      proxifyHtml s = fromMaybe s $ getInnerHtml Nothing $
                        (proxyImages secs conf . detwitterizeEmoji) $ documentRoot $ HTML.parseSTChunks ["<div>", s, "</div>"]
      ppr e = foldr ($) e [ (& key "properties" . key "photo" . values . _String %~ proxifyLink)
                          , (& key "properties" . key "content" . values . key "html" . _String %~ proxifyHtml) ]
  return $ transform (\x → if isJust (x ^? key "type") then ppr x else x) entry


sweetrollServerT ∷ ServerT SweetrollAPI Sweetroll
sweetrollServerT = getIndieConfig :<|> getBaseCss :<|> getDefaultCss :<|> getDefaultIcons
                  :<|> postLogin :<|> getAuth
                  :<|> postMicropub :<|> getMicropub
                  :<|> receiveWebmention
                  :<|> getEntry :<|> getCat :<|> getIndex

sweetrollApp ∷ WaiThrottle → SweetrollCtx → Application
sweetrollApp thr ctx =
    simpleCors
  $ throttle defThr { isThrottled = (\r → return $ requestMethod r /= "GET" && requestMethod r /= "HEAD")
                    , throttleBurst = 5 } thr
  $ autohead
  $ acceptOverride
  $ mapUrls $ mount "bower" (staticApp $ embeddedSettings bowerComponents)
          <|> mount "static" (staticApp $ defaultWebAppSettings "static")
          <|> mount "proxy" (requestProxy ctx)
          <|> mountRoot (serveWithContext sweetrollAPI sweetrollContext $ sweetrollServer ctx)
  where sweetrollServer c = enter (sweetrollToExcept c) sweetrollServerT
        sweetrollContext = authHandler (secretKey $ _ctxSecs ctx) :. EmptyContext
        defThr = defaultThrottleSettings

initSweetrollApp ∷ SweetrollConf → SweetrollSecrets → IO Application
initSweetrollApp conf secs = do
  thr <- initThrottler
  fmap (sweetrollApp thr) $ initCtx conf secs


genLink ∷ MonadSweetroll μ ⇒ Text → URI → μ L.Link<commit_msg>no max-age<commit_after>{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, TemplateHaskell #-}
{-# LANGUAGE TypeOperators, TypeFamilies, DataKinds, TupleSections #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}

module Sweetroll.Api where

import           Sweetroll.Prelude hiding (Context)
import           Data.Maybe (fromJust)
import qualified Data.HashMap.Strict as HMS
import           Data.FileEmbed
import           Data.Microformats2.Parser.HtmlUtil (getInnerHtml)
import qualified Text.HTML.DOM as HTML
import           Text.XML (documentRoot)
import           Text.Pandoc
import           Text.Highlighting.Kate.Format.HTML (styleToCss)
import qualified Network.HTTP.Link as L
import           Network.Wai
import           Network.Wai.UrlMap
import           Network.Wai.Middleware.AcceptOverride
import           Network.Wai.Middleware.Autohead
import           Network.Wai.Middleware.Cors
import           Network.Wai.Middleware.Throttle
import           Network.Wai.Application.Static
import           WaiAppStatic.Types
import           Servant
import           Gitson
import           Gitson.Util (maybeReadIntString)
import           Sweetroll.Conf
import           Sweetroll.Monads
import           Sweetroll.Routes
import           Sweetroll.Pages
import           Sweetroll.Slice
import           Sweetroll.Rendering
import           Sweetroll.Auth
import           Sweetroll.Micropub.Endpoint
import           Sweetroll.Webmention.Receive
import           Sweetroll.Proxy

getIndieConfig ∷ Sweetroll IndieConfig
getIndieConfig = getConfOpt indieConfig

getBaseCss ∷ Sweetroll LByteString
getBaseCss = return $ pandocCss ++ sanitizeCss ++ opentypeCss
  where pandocCss = cs . styleToCss . writerHighlightStyle $ pandocWriterOptions
        sanitizeCss = cs $(embedFile "bower_components/sanitize-css/sanitize.css")
        opentypeCss = cs $(embedFile "bower_components/normalize-opentype.css/normalize-opentype.css")

getDefaultCss ∷ Sweetroll LByteString
getDefaultCss = return $ cs $(embedFile "style.css")

getDefaultIcons ∷ Sweetroll LByteString
getDefaultIcons = return $ cs $(embedFile "icons.svg")

getIndex ∷ Sweetroll (WithLink (View IndexedPage))
getIndex = do
  ipp ← getConfOpt itemsPerPage
  catNames ← getConfOpt categoriesInLanding
  (slices, entries0) ← foldM (\(slices, entries) catName →
                               readCategory ipp Nothing Nothing entries catName >>= \(slices', entries') → return (slices ++ slices', entries'))
                             ([], HMS.empty)
                             catNames
  entries ← postprocessEntries entries0
  selfLink ← genLink "self" $ permalink (Proxy ∷ Proxy IndexRoute)
  addLinks [selfLink] $ mkView $ IndexedPage catNames slices entries

getCat ∷ String → Maybe Int → Maybe Int → Sweetroll (WithLink (View IndexedPage))
getCat catName before after = do
  ipp ← getConfOpt itemsPerPage
  (slice : slices, entries0) ← readCategory ipp before after HMS.empty catName
  entries ← postprocessEntries entries0
  guardBoolM (renderError err404 "404") (not $ null $ sliceItems slice)
  selfLink ← genLink "self" $ catLink slice
  addLinks [selfLink] $ mkView $ IndexedPage [catName] (slice : slices) entries

getEntry ∷ String → String → Sweetroll (WithLink (View EntryPage))
getEntry catName slug = do
  entry ← postprocessEntry =<< (guardJustM (notFoundOrGone catName slug) $ readDocumentByName catName slug)
  -- TODO: cacheHTTPDate -- don't forget responses' dates! -- 204 will be thrown before rendering!
  otherSlugs ← listDocumentKeys catName
  selfLink ← genLink "self" $ permalink (Proxy ∷ Proxy EntryRoute) catName slug
  addLinks [selfLink] $ mkView $ EntryPage catName (map readSlug $ sort otherSlugs) (slug, entry)

postprocessEntries ∷ HashMap α Value → Sweetroll (HashMap α Value)
postprocessEntries = mapM postprocessEntry

postprocessEntry ∷ Value → Sweetroll Value
postprocessEntry entry = do
  secs ← getSecs
  conf ← getConf
  let proxifyLink s = proxiedUri secs s
      proxifyHtml s = fromMaybe s $ getInnerHtml Nothing $
                        (proxyImages secs conf . detwitterizeEmoji) $ documentRoot $ HTML.parseSTChunks ["<div>", s, "</div>"]
      ppr e = foldr ($) e [ (& key "properties" . key "photo" . values . _String %~ proxifyLink)
                          , (& key "properties" . key "content" . values . key "html" . _String %~ proxifyHtml) ]
  return $ transform (\x → if isJust (x ^? key "type") then ppr x else x) entry


sweetrollServerT ∷ ServerT SweetrollAPI Sweetroll
sweetrollServerT = getIndieConfig :<|> getBaseCss :<|> getDefaultCss :<|> getDefaultIcons
                  :<|> postLogin :<|> getAuth
                  :<|> postMicropub :<|> getMicropub
                  :<|> receiveWebmention
                  :<|> getEntry :<|> getCat :<|> getIndex

sweetrollApp ∷ WaiThrottle → SweetrollCtx → Application
sweetrollApp thr ctx =
    simpleCors
  $ throttle defThr { isThrottled = (\r → return $ requestMethod r /= "GET" && requestMethod r /= "HEAD")
                    , throttleBurst = 5 } thr
  $ autohead
  $ acceptOverride
  $ mapUrls $ mount "bower" (staticApp $ embeddedSettings bowerComponents)
          <|> mount "static" (staticApp $ (defaultWebAppSettings "static") { ssMaxAge = NoMaxAge })
          <|> mount "proxy" (requestProxy ctx)
          <|> mountRoot (serveWithContext sweetrollAPI sweetrollContext $ sweetrollServer ctx)
  where sweetrollServer c = enter (sweetrollToExcept c) sweetrollServerT
        sweetrollContext = authHandler (secretKey $ _ctxSecs ctx) :. EmptyContext
        defThr = defaultThrottleSettings

initSweetrollApp ∷ SweetrollConf → SweetrollSecrets → IO Application
initSweetrollApp conf secs = do
  thr <- initThrottler
  fmap (sweetrollApp thr) $ initCtx conf secs


genLink ∷ MonadSweetroll μ ⇒ Text → URI → μ L.Link
{'fraction_non_alphanumeric': 0.08428559154566544, 'fraction_numerical': 0.0025775410258613283, 'mean_word_length': 3.1795332136445245, 'pattern_counts': {'":': 0, '<': 41, '<?xml version=': 0, '>': 39, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2325952', 'n_tokens_mistral': 3581, 'n_tokens_neox': 3420, 'n_words': 1042}