87 lines
2.7 KiB
Haskell
87 lines
2.7 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE OverloadedRecordDot #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Main (main) where
|
|
|
|
import Control.Concurrent (getNumCapabilities)
|
|
import Control.Exception (Exception, throwIO)
|
|
import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
|
|
import Data.Proxy (Proxy (..))
|
|
import Data.Text (Text)
|
|
import Network.HTTP.Media ((//), (/:))
|
|
import Network.HTTP.Types (status200)
|
|
import Servant (Accept (..), Get, Server, serve, MimeRender (..), (:<|>) (..), (:>), Raw, Capture, Tagged (..))
|
|
import System.FilePath ((</>))
|
|
import Text.Blaze.Html5 ((!))
|
|
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
|
|
import Text.Printf (printf)
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Database.PostgreSQL.Opium as Opium
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import qualified Text.Blaze.Html5 as H
|
|
import qualified Text.Blaze.Html5.Attributes as A
|
|
import Network.Wai (responseFile)
|
|
|
|
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 =
|
|
pure $ RootModel "/api/today/issue/0/fz.pdf"
|
|
|
|
todayR issue =
|
|
pure $ RootModel $ Text.pack $ printf "/api/today/issue/%d/fz.pdf" issue
|
|
|
|
apiTodayR issue =
|
|
Tagged $ \_ respond -> do
|
|
dateNow <- getCurrentDay
|
|
let Just dateThen = addYears (-100) dateNow
|
|
print dateThen
|
|
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
|
|
|
|
newtype RootModel = RootModel Text
|
|
|
|
instance MimeRender HTML RootModel where
|
|
mimeRender _ (RootModel url) = renderHtml $ do
|
|
H.docTypeHtml $ do
|
|
H.body ! A.style "margin: 0" $ do
|
|
H.iframe ! A.src (H.toValue url) ! A.style "width: 100vw; height: 100vh; border: 0;" $ mempty
|
|
|
|
-- Utils
|
|
|
|
data HTML
|
|
|
|
instance Accept HTML where
|
|
contentType _ = "text" // "html" /: ("charset", "utf-8")
|