{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Main (main) where

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Data.Time (Day, toGregorian)
import GHC.Generics (Generic)
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 Envy (type (=@!), type (=@@), type (?))
import Yore.DB (DayFile (..))
import Yore.Error (Error (..))
import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)

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

newtype ConnectionString = ConnectionString String
  deriving (Show)

instance Envy.ReadEnvVar ConnectionString where
  readEnvVar = fmap ConnectionString . Envy.readEnvVar

data ConfigT f = Config
  { yorePort :: f =@@ Int ? 3000
  , yoreDownloadDir :: f =@@ FilePath ? "./download"
  , yoreDb :: f =@! Text
  }
  deriving (Generic)

type Config = ConfigT Envy.Value

deriving instance Show Config

main :: IO ()
main = do
  cfg <- Envy.load @ConfigT
  -- _ <- exitSuccess

  let
    settings =
      foldr
        ($)
        Warp.defaultSettings
        [ Warp.setLogger logger
        , Warp.setPort cfg.yorePort
        , Warp.setBeforeMainLoop $ Log.info $ printf "listening on port %d" cfg.yorePort
        , Warp.setOnException onException
        ]

  db <- DB.initDB cfg.yoreDb
  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server cfg db
  where
    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 :: Config -> DB.DB -> ServerT API (ExceptT Error IO)
server cfg 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 = cfg.yoreDownloadDir </> 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