125 lines
4.0 KiB
Haskell
125 lines
4.0 KiB
Haskell
{-# 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 (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.Text as Text
|
|
import qualified Database.PostgreSQL.Opium as Opium
|
|
import Network.Wai (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)
|
|
|
|
import qualified Yore.DB as DB
|
|
|
|
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.run 3000 $ serve (Proxy :: Proxy API) $ server connPool
|
|
|
|
where
|
|
unsafeConnect s = either throwIO pure =<< Opium.connect s
|
|
|
|
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
|
|
|
|
respond $ responseFile status200 [("content-type", "application/pdf")] 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.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
|
|
let (y, m, d) = toGregorian dateThen
|
|
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
|
|
|
|
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
|