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

module Main (main) where

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Data.Proxy (Proxy (..))
import Data.Time (Day, toGregorian)
import Network.HTTP.Media ((//), (/:))
import Network.HTTP.Types (Status (..), mkStatus, status200)
import Servant
  ( Accept (..)
  , Capture
  , Get
  , Handler
  , MimeRender (..)
  , Raw
  , ServerError (..)
  , ServerT
  , Tagged (..)
  , err404
  , err500
  , hoistServer
  , runHandler
  , serve
  , (:<|>) (..)
  , (:>)
  , pattern MkHandler
  )
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.ByteString.Lazy as LBS
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Encoding
import qualified Database.PostgreSQL.Opium as Opium
import Network.Wai (Application, Request (..), Response, responseFile, responseLBS)
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.Error (Error (..))
import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)

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

main :: IO ()
main = do
  db <- DB.initDB "host=localhost user=yore-test port=5433 dbname=yore-test"
  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server db
  where
    settings =
      Warp.setLogger logger $
        Warp.setOnException onException Warp.defaultSettings

    logger req status _ = do
      Log.info $
        printf
          "%d %s"
          (statusCode status)
          (requestLine req)

    requestLine :: Request -> String
    requestLine req =
      printf
        "%s %s"
        (BS8.unpack $ requestMethod req)
        (BS8.unpack $ rawPathInfo req <> rawQueryString req)

    onException mbReq ex = do
      Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex)

nt :: ExceptT Error IO a -> Handler a
nt action = MkHandler $ do
  res <- runExceptT action
  case res of
    Left err -> do
      Log.error $ show err
      pure $ Left $ toServerError err
    Right x ->
      pure $ Right x

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

toServerError :: Error -> ServerError
toServerError = \case
  ConnectionError msg ->
    err500 {errBody = encodeUtf8LBS $ "database connection failed:\n" ++ show msg}
  DBError (Opium.ErrorNotExactlyOneRow 0) ->
    err404 {errBody = "db error: could not find record"}
  DBError msg ->
    err500 {errBody = encodeUtf8LBS $ "db error: " ++ show msg}
  GenericError msg ->
    err500 {errBody = encodeUtf8LBS $ "generic error:\n" ++ show msg}

encodeUtf8LBS :: String -> LBS.ByteString
encodeUtf8LBS = LBS.fromStrict . Encoding.encodeUtf8 . Text.pack

handlerToRaw :: ExceptT Error IO Response -> Tagged t Application
handlerToRaw handler = Tagged $ \_ respond -> do
  r <- runHandler $ nt handler
  case r of
    Left e ->
      respond $ responseLBS (mkStatus e.errHTTPCode $ BS8.pack e.errReasonPhrase) e.errHeaders e.errBody
    Right response ->
      respond response

server :: DB.DB -> ServerT API (ExceptT Error IO)
server db = rootR :<|> todayR :<|> apiTodayR
  where
    rootR = todayR 0

    todayR issue = do
      dateThen <- ExceptT get100YearsAgo
      count <- ExceptT $ DB.withConn db $ DB.getNumberOfIssues dateThen
      dayFile <- ExceptT $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
      pure $ RootModel dateThen dayFile issue count

    apiTodayR issue = handlerToRaw $ do
      dateThen <- ExceptT get100YearsAgo
      dayFile <- ExceptT $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
      let fullPath = "download" </> dayFile.relative_path
      secondsUntilMidnight <- liftIO getSecondsUntilMidnight
      pure $
        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 (Either Error Day)
get100YearsAgo =
  either (Left . GenericError . ("can't go back 100 years: " <>)) Right . addYears (-100) <$> getCurrentDay