{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | spawns a few processes that serve the que.run website
--
-- : out que-website
--
-- : dep async
-- : dep docopt
-- : dep config-ini
-- : dep process
-- : dep protolude
-- : dep req
-- : dep tasty
-- : dep tasty-hunit
-- : dep tasty-quickcheck
module Biz.Que.Site
  ( main,
  )
where

import Alpha
import qualified Biz.Cli as Cli
import Biz.Test ((@=?))
import qualified Biz.Test as Test
import qualified Control.Concurrent.Async as Async
import qualified Data.ByteString.Char8 as BS
import qualified Data.Ini.Config as Config
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.IO as Text
import Network.HTTP.Req
import qualified System.Directory as Directory
import System.Environment as Environment
import qualified System.Exit as Exit
import System.FilePath ((</>))
import qualified System.Process as Process

main :: IO ()
main = Cli.main <| Cli.Plan help move test

move :: Cli.Arguments -> IO ()
move args = do
  let (Just src, Just ns) = (getArg "src", Text.pack </ getArg "ns")
  mKey <- getKey ns
  putText <| "serving " <> Text.pack src <> " at " <> ns
  run mKey ns
    <| Sources
      { index = src </> "Index.md",
        client = src </> "Client.py",
        quescripts = src </> "Quescripts.md",
        style = src </> "Style.css",
        apidocs = src </> "Apidocs.md",
        tutorial = src </> "Tutorial.md"
      }
  where
    getArg = Cli.getArg args <. Cli.argument

help :: Cli.Docopt
help =
  [Cli.docopt|
que-website

Usage:
  que-website <src> <ns>
  que-website test
|]

test :: Test.Tree
test = Test.group "Biz.Que.Site" [Test.unit "id" <| 1 @=? (1 :: Integer)]

getKey :: Namespace -> IO (Maybe Key)
getKey ns = do
  home <- Directory.getHomeDirectory
  let file = home </> ".config" </> "que.conf"
  exists <- Directory.doesFileExist file
  unless exists <| panic <| "not found: " <> Text.pack file
  conf <- Text.readFile file
  print (home </> ".config" </> "que.conf")
  auth ns
    |> Config.parseIniFile conf
    |> either errorParsingConf identity
    |> return

errorParsingConf :: error
errorParsingConf = panic "could not parse ~/.config/que.conf"

data Sources = Sources
  { index :: FilePath,
    quescripts :: FilePath,
    client :: FilePath,
    style :: FilePath,
    tutorial :: FilePath,
    apidocs :: FilePath
  }

type Namespace = Text

type Key = Text

auth :: Namespace -> Config.IniParser (Maybe Key)
auth "pub" = pure Nothing
auth ns = Config.sectionMb ns <| Config.field "key"

run :: Maybe Key -> Text -> Sources -> IO ()
run key ns Sources {..} = Async.runConcurrently actions |> void
  where
    actions =
      traverse
        Async.Concurrently
        [ forever <| toHtml index >>= serve key ns "index",
          forever <| toHtml quescripts >>= serve key ns "quescripts",
          forever <| BS.readFile client >>= serve key ns "client",
          forever <| toHtml tutorial >>= serve key ns "tutorial",
          forever <| toHtml apidocs >>= serve key ns "apidocs"
        ]
    toHtml :: FilePath -> IO ByteString
    toHtml md =
      BS.pack
        </ Process.readProcess
          "pandoc"
          [ "--include-in-header",
            style,
            "-i",
            md,
            "--from",
            "markdown",
            "--to",
            "html"
          ]
          []

serve :: Maybe Key -> Namespace -> Text -> ByteString -> IO ()
serve Nothing "pub" path content =
  runReq defaultHttpConfig <| do
    _ <-
      req
        POST
        (http "que.run" /: "pub" /: path)
        (ReqBodyBs content)
        ignoreResponse
        mempty
    liftIO <| return ()
serve Nothing p _ _ = panic <| "no auth key provided for ns: " <> p
serve (Just key) ns path content =
  runReq defaultHttpConfig <| do
    let options =
          header "Authorization" (encodeUtf8 key) <> responseTimeout maxBound
    _ <-
      req
        POST
        (http "que.run" /: ns /: path)
        (ReqBodyBs content)
        ignoreResponse
        options
    liftIO <| return ()