module Main (main) where

import Prelude

import Hakyll

import Data.Bool
import Data.List qualified as List
import Data.Maybe

import System.FilePath
import System.FilePath.Glob qualified as Glob

import Data.Yaml qualified as Yaml

import Data.Map (Map)
import Data.Map qualified as Map

import Control.Monad
import Control.Monad.Reader.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader (Reader, runReader)

import Control.Applicative

import Data.Text.Lazy qualified as Lazy (Text)
import Data.Text.Lazy.IO qualified as LT
import Text.Megaparsec (Parsec, ParsecT)
import Text.Megaparsec qualified as MP
import Text.Megaparsec.Char qualified as MP

import Data.Text (Text)
import Data.Text qualified as T

import Control.Exception
import System.IO.Error

import Data.Void

config :: Configuration
config =
  defaultConfiguration
    { destinationDirectory = "public"
    }

routeAsFilePath :: (FilePath -> FilePath) -> Routes
routeAsFilePath f = customRoute $ f . toFilePath

stripPathPrefix :: FilePath -> (FilePath -> FilePath)
stripPathPrefix (splitDirectories -> prefix) =
  joinPath . (\x -> fromMaybe x $ List.stripPrefix prefix x) . splitDirectories

handleIf :: Exception e => (e -> Bool) -> (e -> IO a) -> IO a -> IO a
handleIf predicate handler = handle $ \exc -> bool throwIO handler (predicate exc) exc

main :: IO ()
main = hakyllWith config $ do
  frontendManifest <-
    preprocess $
      Yaml.decodeFileThrow @_ @(Map String [FilePath]) "frontend/dist/.manifest.yaml"
  let
    frontendContext = jsContext <> cssContext
      where
        cssContext = listField "css" innerContext genCSSItems
          where
            innerContext = urlField "url"
            genCSSItems = genManifestItems $ Glob.compile "**/*.css"
        jsContext = listField "js" innerContext genCSSItems
          where
            innerContext = urlField "url"
            genCSSItems = genManifestItems $ Glob.compile "**/*.js"

        genManifestItems :: Glob.Pattern -> Compiler [Item CopyFile]
        genManifestItems p = do
          let entryPoint = "main"
              resources = filter (Glob.match p) $ frontendManifest Map.! entryPoint
          forM resources $ load . fromFilePath . ("frontend/dist" </>) . dropDrive

  netlifyRedirects <-
    preprocess . handleIf isDoesNotExistError (const $ return []) $
      let pNetlify :: ParsecT Void Lazy.Text m [(FilePath, FilePath)]
          pNetlify = catMaybes <$> MP.sepBy (MP.space *> pLine <* MP.hspace) pEOL <* MP.eof
            where
              pEOL :: ParsecT Void Lazy.Text m ()
              pEOL = void . MP.label "linebreak" $ MP.eol
              pLine :: ParsecT Void Lazy.Text m (Maybe (FilePath, FilePath))
              pLine = MP.label "line" $ (mempty <$ pComment) <|> pRedirect <|> pure Nothing
              pComment :: ParsecT Void Lazy.Text m ()
              pComment = void $ MP.char '#' *> MP.label "comment" (MP.manyTill MP.anySingle $ MP.lookAhead MP.eol)
              pRedirect :: ParsecT Void Lazy.Text m (Maybe (FilePath, FilePath))
              pRedirect = do
                fromRoute <- MP.label "fromRoute" $ MP.manyTill MP.anySingle MP.separatorChar
                MP.hspace
                toRoute <- MP.label "toRoute" $ MP.manyTill MP.anySingle MP.separatorChar
                MP.hspace
                redirectMode <- MP.label "mode" $ asum [MP.string "200", MP.string "301", MP.string "302"]
                return $
                  if
                      | redirectMode == "200" -> Just (fromRoute, toRoute)
                      | otherwise -> Nothing
       in either throwIO return =<< MP.runParserT pNetlify "static/_redirects" =<< LT.readFile "static/_redirects"
  let
    renderRoute r
      | fromRoute : _ <- mapMaybe (matchNetlifyRedirect r) netlifyRedirects =
          fromRoute
      | otherwise =
          r
      where
        matchNetlifyRedirect :: FilePath -> (FilePath, FilePath) -> Maybe FilePath
        matchNetlifyRedirect r' (fromRoute, toRoute) = do
          tokens <- MP.parseMaybe pToSpec toRoute
          Right subst <- return $ runReader (MP.runParserT (pRoute tokens <* MP.eof) "" r') Map.empty
          return . T.unpack $ Map.foldrWithKey doSubst (T.pack fromRoute) subst
          where
            pToSpec :: Parsec Void FilePath [Either FilePath String]
            pToSpec =
              MP.some $
                Left <$> MP.someTill (MP.anySingleBut ':') (MP.lookAhead $ MP.eof <|> void (MP.single ':'))
                  <|> Right <$> (MP.char ':' *> MP.some MP.letterChar)
            pRoute :: [Either FilePath String] -> ParsecT Void FilePath (Reader (Map String String)) (Map String String)
            pRoute [] = MP.eof *> ask
            pRoute (t : ts) = case t of
              Left str -> MP.string str *> pRoute ts
              Right p -> do
                pVal <- asks $ Map.lookup p
                case pVal of
                  Nothing -> do
                    mLength <- length <$> MP.getInput
                    asum . flip map [0 .. mLength] $ \l -> MP.try $ do
                      val <- MP.takeP (Just $ ':' : p) l
                      newSubst <- asks $ Map.insert p val
                      newSubst <$ local (const newSubst) (pRoute ts)
                  Just pVal' -> MP.string pVal' *> ask

            doSubst :: String -> String -> Text -> Text
            doSubst k s = T.intercalate (T.pack s) . T.splitOn (T.pack $ ':' : k)
    normalizeUrls :: Item String -> Compiler (Item String)
    normalizeUrls item = do
      itemRoute <- getRoute $ itemIdentifier item
      let relativizeUrls' x = case itemRoute of
            Just r
              | "/" `List.isPrefixOf` x && not ("//" `List.isPrefixOf` x) ->
                  toSiteRoot r ++ x
            _other -> x
      return $ withUrls (relativizeUrls' . renderRoute) <$> item

  tags <- buildTags "content/**" $ fromCapture "tags/*.html"

  match "content/**" $ do
    compile $ do
      pandocCompiler
        >>= normalizeUrls

  forM_ (tagsMap tags) $ \(tag, fromList -> posts) ->
    rulesExtraDependencies [tagsDependency tags] $ do
      tagItems <- getMatches . fromGlob $ toFilePath (tagsMakeId tags tag) -<.> "*"
      let tagItem = pandocCompiler <|> makeItem mempty
          rule
            | [] <- tagItems = create [tagsMakeId tags tag]
            | otherwise = match (fromList tagItems)

      rule $ do
        route . routeAsFilePath $ (-<.> "html") . stripPathPrefix "tags"
        compile $ do
          let
            ctx =
              mconcat
                [ listField "tags-nav" defaultContext (metadataSort <=< mapM (uncurry renderTagNav) $ tagsMap tags)
                , listField "posts" postContext (metadataSort =<< loadAll posts)
                , frontendContext
                , defaultContext
                ]

            renderTagNav tag' ids = do
              tagItems' <- getMatches . fromGlob $ toFilePath (tagsMakeId tags tag') -<.> "*"
              let
                tagItem' = return $ Item (fromMaybe (tagsMakeId tags tag') $ listToMaybe tagItems') (mempty :: String)

                navRoute = renderRoute $ "/" <> tag' <> ".html"

                tagNavCtx =
                  mconcat
                    [ constField "tag" tag'
                    , field "title" . const $
                        fmap (fromMaybe tag') . runMaybeT . asum $
                          map (\itemId -> MaybeT $ getMetadataField itemId "title") tagItems'
                    , constField "route" navRoute
                    , listField "posts" (constField "tag" tag' <> constField "route" navRoute <> postContext) (metadataSort =<< mapM load ids)
                    ]
              tagItem'
                >>= loadAndApplyTemplate "templates/tag-nav.html" tagNavCtx
                >>= normalizeUrls

            postContext =
              mconcat
                [ field "identifier" (return . takeBaseName . toFilePath . itemIdentifier)
                , defaultContext
                ]

            metadataSort :: [Item w] -> Compiler [Item w]
            metadataSort = sortOnM $ \Item{itemIdentifier} -> maybe (0 :: Integer) read <$> getMetadataField itemIdentifier "sort"
              where
                sortOnM :: forall m a b. (Monad m, Ord b) => (a -> m b) -> [a] -> m [a]
                sortOnM f = fmap (map snd . List.sortOn fst) . mapM (\x -> (,x) <$> f x)

          tagItem
            >>= loadAndApplyTemplate "templates/tag.html" ctx
            >>= loadAndApplyTemplate "templates/site-layout.html" ctx
            >>= normalizeUrls

  match "frontend/dist/wp-*/**" $ do
    route . routeAsFilePath $ stripPathPrefix "frontend/dist"

    compile copyFileCompiler

  match "templates/*" $ compile templateBodyCompiler

  match "static/**" $ do
    route . routeAsFilePath $ stripPathPrefix "static"
    compile copyFileCompiler