{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

-- | Server
module Ibb where

import Alpha
import Biz.Ibb
import qualified Biz.Ibb.Keep as Keep
import qualified Biz.Ibb.Look as Look
import qualified Clay
import qualified Data.Text.Lazy                as Lazy
import qualified Data.Text.Lazy.Encoding       as Lazy
import Data.Maybe (fromMaybe)
import Data.Acid (AcidState)
import qualified Data.Acid.Abstract as Acid
import GitHash (giHash, tGitInfoCwd)
import qualified Lucid as L
import Lucid.Base
import Miso
import           Network.HTTP.Media             ((//), (/:))
import Network.HTTP.Types
import Network.RemoteData
import Network.Wai
import Network.Wai.Application.Static
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.RequestLogger
import Servant
import System.Environment (lookupEnv)

main :: IO ()
main = do
  say "rise: ibb"
  port <- read
          <$> fromMaybe "3000"
          <$> lookupEnv "PORT" :: IO Int
  keep <- Keep.openLocal "keep/"
  say "port: 3000"
  run port $ logStdout $ compress $ app $ keep
    where
      compress = gzip def { gzipFiles = GzipCompress }

newtype HtmlPage a = HtmlPage a
  deriving (Show, Eq)

instance L.ToHtml a => L.ToHtml (HtmlPage a) where
  toHtmlRaw = L.toHtml
  toHtml (HtmlPage x) =
    L.doctypehtml_ $ do
      L.head_ $ do
        L.meta_ [L.charset_ "utf-8"]
        jsRef "/static/all.js"
        cssRef "/css/main.css"
      L.body_ $ do
        page
        L.p_ gitCommit
    where
      page = L.toHtml x
      gitCommit = L.toHtml $ giHash $$tGitInfoCwd
      jsRef href = L.with (L.script_ mempty)
        [ makeAttribute "src" href
        , makeAttribute "type" "text/javascript"
        , makeAttribute "async" mempty
        , makeAttribute "defer" mempty
        ]
      cssRef href = L.with
        (L.link_ mempty)
        [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]

type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action

handle404 :: Application
handle404 _ respond = respond
  $ responseLBS status404 [("Content-Type", "text/html")]
  $ renderBS
  $ toHtml
  $ HtmlPage
  $ notfound

newtype CSS = CSS { unCSS :: Text }

instance MimeRender CSS Text where
  mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict

instance Accept CSS where
  contentType _ = "text" // "css" /: ("charset", "utf-8")

type CssRoute = "css" :> "main.css" :> Get '[CSS] Text

type Routes
  = "static" :> Raw
  :<|> CssRoute
  :<|> ServerRoutes
  :<|> "api" :> ApiRoutes
  :<|> Raw

cssHandlers :: Server CssRoute
cssHandlers = return . Lazy.toStrict . Clay.render
    $ Look.main

app :: AcidState Keep.IbbKeep -> Application
app keep = serve
  (Proxy @Routes)
  $ static
  :<|> cssHandlers
  :<|> serverHandlers
  :<|> apiHandlers keep
  :<|> Tagged handle404
  where
    static = serveDirectoryWith (defaultWebAppSettings "ibb.jsexe")

type ApiRoutes =
  "people" :> Get '[JSON] [Person]

serverHandlers :: Server ServerRoutes
serverHandlers = homeHandler
  where
    send f u =
      pure $ HtmlPage $ f Model { uri = u, people = NotAsked }
    homeHandler = send home goHome

-- | for now we just have one api endpoint, which returns all the people
apiHandlers :: AcidState Keep.IbbKeep -> Server ApiRoutes
apiHandlers keep =
  Acid.query' keep $ Keep.GetPeople 20