149 lines
4.8 KiB
Haskell
149 lines
4.8 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 (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
|