yore/app/Main.hs

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

module Main (main) where

import Control.Monad.IO.Class (liftIO)
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
  , Server
  , ServerError (..)
  , Tagged (..)
  , err404
  , err500
  , 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.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) $ 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" (show ex) (maybe "" ((" in " ++) . requestLine) mbReq)

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

succeed :: (ToServerError e) => IO (Either e a) -> Handler a
succeed action = MkHandler $ mapLeft toServerError <$> action
  where
    mapLeft f = either (Left . f) Right

class ToServerError e where
  toServerError :: e -> ServerError

instance ToServerError DB.Error where
  toServerError = \case
    DB.ConnectionError msg ->
      err500 {errBody = encodeUtf8LBS $ "database connection failed:\n" ++ show msg}
    DB.Error (Opium.ErrorNotExactlyOneRow 0) ->
      err404 {errBody = "could not find record"}
    e ->
      err500 {errBody = encodeUtf8LBS $ show e}

instance ToServerError String where
  toServerError s =
    err500 {errBody = encodeUtf8LBS s}

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

handlerToRaw :: Handler Response -> Tagged t Application
handlerToRaw handler = Tagged $ \_ respond -> do
  r <- runHandler 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 -> Server API
server db = rootR :<|> todayR :<|> apiTodayR
  where
    rootR = todayR 0

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

    apiTodayR issue = handlerToRaw $ do
      dateThen <- succeed get100YearsAgo
      dayFile <- succeed $ 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 String Day)
get100YearsAgo =
  maybe (Left "can't go back 100 years") Right . addYears (-100) <$> getCurrentDay