{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import Control.Concurrent (getNumCapabilities)
import Control.Exception (ErrorCall (..), Exception, throwIO)
import Control.Monad.IO.Class (liftIO)
import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
import Data.Proxy (Proxy (..))
import Data.Time (Day, toGregorian)
import Network.HTTP.Media ((//), (/:))
import Network.HTTP.Types (Status (..), status200)
import Servant
  ( Accept (..)
  , Capture
  , Get
  , MimeRender (..)
  , Raw
  , Server
  , Tagged (..)
  , serve
  , (:<|>) (..)
  , (:>)
  )
import System.FilePath ((</>))
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Blaze.Html5 ((!))
import Text.Printf (printf)

import qualified Data.ByteString.Char8 as BS8
import qualified Data.Text as Text
import qualified Database.PostgreSQL.Opium as Opium
import Network.Wai (Request (..), responseFile)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

import Yore.DB (DayFile (..))
import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)

import qualified Yore.DB as DB
import qualified Yore.Log as Log

instance Exception Opium.ConnectionError

main :: IO ()
main = do
  capabilities <- getNumCapabilities
  let maxResources = capabilities
  connPool <-
    newPool $
      defaultPoolConfig
        (unsafeConnect "host=localhost port=5433 user=yore-test dbname=yore-test")
        Opium.close
        10
        maxResources
  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ server connPool
  where
    unsafeConnect s = either throwIO pure =<< Opium.connect s

    settings = Warp.setLogger logger Warp.defaultSettings

    logger req status _ = do
      Log.info $
        printf
          "%d %s %s"
          (statusCode status)
          (BS8.unpack $ requestMethod req)
          (BS8.unpack $ rawPathInfo req <> rawQueryString req)

type API =
  Get '[HTML] RootModel
    :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel
    :<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> Raw

server :: Pool Opium.Connection -> Server API
server connPool = rootR :<|> todayR :<|> apiTodayR
  where
    rootR = todayR 0

    todayR issue = do
      dateThen <- liftIO get100YearsAgo
      Right count <- liftIO $ withResource connPool $ DB.getNumberOfIssues dateThen
      Right dayFile <- liftIO $ withResource connPool $ DB.getDayFileByIssue dateThen issue
      pure $ RootModel dateThen dayFile issue count

    apiTodayR issue =
      Tagged $ \_ respond -> do
        dateThen <- get100YearsAgo
        res <- withResource connPool $ DB.getDayFileByIssue dateThen issue
        dayFile <- either throwIO pure res
        let fullPath = "download" </> dayFile.relative_path
        secondsUntilMidnight <- getSecondsUntilMidnight

        respond $
          responseFile
            status200
            [ ("content-type", "application/pdf")
            , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight)
            ]
            fullPath
            Nothing

data RootModel = RootModel Day DB.DayFile Int Int

instance MimeRender HTML RootModel where
  mimeRender _ (RootModel dateThen dayFile issue count) = renderHtml $ do
    H.docTypeHtml $ do
      H.head $ do
        H.title $ H.text $ Text.pack $ printf "FZ ⊛ %02d.%02d.%04d ⊛ %s" d m y dayFile.label
        H.style
          "body { margin: 0; font-family: Helvetica, sans-serif; } .layout { display: flex; flex-direction: column; width: 100vw; height: 100vh; } .topbar { user-select: none; text-align: center; padding: .5em; } .content { flex: 1; } iframe { border: 0; }"
      H.body $ do
        H.div ! A.class_ "layout" $ do
          H.div ! A.class_ "topbar" $ do
            H.text $ Text.pack $ printf "Freiburger Zeitung ⊛ %02d.%02d.%04d" d m y
            H.br
            buildLink "⟽" (issue - 1)
            H.text $ " " <> dayFile.label <> " "
            buildLink "⟾" (issue + 1)
          H.iframe ! A.src (H.toValue url) ! A.class_ "content" $ mempty
    where
      url :: String
      url = printf "/api/today/issue/%d/fz.pdf" issue

      (y, m, d) = toGregorian dateThen

      buildLink label issue'
        | issue' == 0 =
            H.a ! A.href "/" $ label
        | issue' > 0 && issue' < count =
            H.a ! A.href (H.toValue (printf "/today/issue/%d" issue' :: String)) $ label
        | otherwise =
            H.span ! A.style "color: grey;" $ label

-- Utils

data HTML

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

get100YearsAgo :: IO Day
get100YearsAgo = do
  dateNow <- getCurrentDay
  maybe (throwIO $ ErrorCall "cant go back 100 years") pure $ addYears (-100) dateNow