Compare commits
43
Commits
22867bc229
...
v0.0.12
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
5cce1fc042 | ||
|
|
859f1d189e | ||
|
|
9959c36a42 | ||
|
|
dbacbb10ad | ||
|
|
d736766981 | ||
|
|
de08373d2d | ||
|
|
ad348e2c60 | ||
|
|
de11a86285 | ||
|
|
799cd1c938 | ||
|
|
7ee3b26b7a | ||
|
|
5ee534c42c | ||
|
|
cf583f5ff6 | ||
|
|
d3dbb6e673 | ||
|
|
851b3a6076 | ||
|
|
dbc3103980 | ||
|
|
2dacd4f747 | ||
|
|
94ede9a168 | ||
|
|
c38574e005 | ||
|
|
700d53fbb0 | ||
|
|
c5c11ed181 | ||
|
|
36c9b880a7 | ||
|
|
c25ead672b | ||
|
|
4a6e3b2454 | ||
|
|
b739294638 | ||
|
|
27f5b8e23c | ||
|
|
48eb27e218 | ||
|
|
94554ad6e4 | ||
|
|
1ccde9e5fc | ||
|
|
999c9e8c9e | ||
|
|
eff74cecb4 | ||
|
|
e9934276d5 | ||
|
|
72ffa08e18 | ||
|
|
2b85c0fa93 | ||
|
|
05943c902e | ||
|
|
0bf734730b | ||
|
|
f2a136d27c | ||
|
|
85bbc8516a | ||
|
|
ac8e8a404a | ||
|
|
fa60291779 | ||
|
|
dbea1c549f | ||
|
|
82d8ce63d8 | ||
|
|
67127fd28d | ||
|
|
368bbb0124 |
@@ -0,0 +1,27 @@
|
||||
name: build
|
||||
on:
|
||||
pull_request:
|
||||
jobs:
|
||||
build:
|
||||
container:
|
||||
image: node:24-bookworm
|
||||
env:
|
||||
USER: node
|
||||
HOME: /home/node
|
||||
NIX_CONFIG: experimental-features = nix-command flakes
|
||||
volumes:
|
||||
- /var/lib/pbri/docker/nix_runner_nix:/nix
|
||||
- /var/lib/pbri/docker/nix_runner_etc:/etc/nix
|
||||
- /var/lib/pbri/docker/nix_runner_home_node:/home/node
|
||||
options: --user 1000:1000
|
||||
steps:
|
||||
- name: Prep nix env
|
||||
run: |
|
||||
if [ ! -f ~/.nix-profile/etc/profile.d/nix.sh ]; then
|
||||
curl -L https://nixos.org/nix/install | bash -s -- --no-daemon
|
||||
fi
|
||||
. ~/.nix-profile/etc/profile.d/nix.sh
|
||||
env >> "$GITHUB_ENV"
|
||||
- name: Checkout repo
|
||||
uses: actions/checkout@v4
|
||||
- run: nix build --log-format raw --print-build-logs .#yore
|
||||
@@ -0,0 +1,40 @@
|
||||
name: deliver
|
||||
on:
|
||||
push:
|
||||
tags:
|
||||
- 'v*'
|
||||
jobs:
|
||||
deliver:
|
||||
container:
|
||||
image: node:24-bookworm
|
||||
env:
|
||||
USER: node
|
||||
HOME: /home/node
|
||||
NIX_CONFIG: experimental-features = nix-command flakes
|
||||
volumes:
|
||||
- /var/lib/pbri/docker/nix_runner_nix:/nix
|
||||
- /var/lib/pbri/docker/nix_runner_etc:/etc/nix
|
||||
- /var/lib/pbri/docker/nix_runner_home_node:/home/node
|
||||
options: --user 1000:1000
|
||||
steps:
|
||||
- name: Prep nix env
|
||||
run: |
|
||||
if [ ! -f ~/.nix-profile/etc/profile.d/nix.sh ]; then
|
||||
curl -L https://nixos.org/nix/install | bash -s -- --no-daemon
|
||||
fi
|
||||
. ~/.nix-profile/etc/profile.d/nix.sh
|
||||
env >> "$GITHUB_ENV"
|
||||
- name: Checkout repo
|
||||
uses: actions/checkout@v4
|
||||
- name: Get image meta
|
||||
run: nix build .#yore-meta -o /tmp/yore-meta
|
||||
- name: Version check
|
||||
run: |
|
||||
VERSION=$(cat /tmp/yore-meta/version)
|
||||
[ "$GITHUB_REF_NAME" = v"$VERSION" ]
|
||||
- run: nix build --log-format raw --print-build-logs .#image -o image.tar.gz
|
||||
- run: gunzip -c image.tar.gz > image.tar
|
||||
- run: nix run .#crane -- auth login git.pbrinkmeier.de -u paul -p "$PASSWORD"
|
||||
env:
|
||||
PASSWORD: "${{ secrets.REGISTRY_PASSWORD }}"
|
||||
- run: nix run .#crane -- push image.tar $(cat /tmp/yore-meta/image-tag)
|
||||
@@ -1,5 +1,12 @@
|
||||
# yore
|
||||
|
||||
[fz.beany.club](https://fz.beany.club) shows the [Freiburger Zeitung](https://www.ub.uni-freiburg.de/?id=117) (an important Freiburg im Breisgau newspaper going back to 1784) from exactly 100 years ago.
|
||||
It is feature-poor on purpose: You can browse a daily issue during your coffee break and that is basically it.
|
||||
|
||||
|  |  |
|
||||
| --- | --- |
|
||||
| October 5th, 1925 | September 15th, 1926 |
|
||||
|
||||
## Development
|
||||
|
||||
`flake.nix` defines a development shell that has everything you'll need. To enter, run
|
||||
@@ -25,7 +32,7 @@ You can also use it to run a database for development by choosing a `$COMMAND` t
|
||||
```
|
||||
BASE_DIR=./pgdata scripts/with-db psql "dbname=yore-test port=5433 user=yore-test"
|
||||
# cabal repl with env vars set
|
||||
BASE_DIR=./pgdata scripts/with-db scripts/dev
|
||||
BASE_DIR=./pgdata scripts/with-db cabal run
|
||||
```
|
||||
|
||||
By setting `$BASE_DIR` you can persist the database for later runs.
|
||||
@@ -41,6 +48,10 @@ By setting `$BASE_DIR` you can persist the database for later runs.
|
||||
|
||||
## TODO
|
||||
|
||||
- CI
|
||||
- Docker container (in flake)
|
||||
- try fourmolu
|
||||
- [x] CI
|
||||
- [x] Docker container (in flake)
|
||||
- [x] try fourmolu
|
||||
- [x] Test leap second handling in the `time` package
|
||||
- [x] Fix container shutdown delay
|
||||
- [ ] Fix `responseFile` always returning 200
|
||||
- [x] Vendor PDF.js for consistent cross-platform PDF rendering
|
||||
|
||||
+129
-69
@@ -10,29 +10,30 @@
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Monad (forM, forM_)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
|
||||
import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT)
|
||||
import Data.Bifunctor (Bifunctor (..))
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.Text (Text)
|
||||
import Data.Time (Day, toGregorian)
|
||||
import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, nominalDiffTimeToSeconds, toGregorian)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Media ((//), (/:))
|
||||
import Network.HTTP.Types (Status (..), mkStatus, status200)
|
||||
import Network.HTTP.Types (Status (..))
|
||||
import Network.Wai (Middleware, Request (..), responseStatus)
|
||||
import Servant
|
||||
( Accept (..)
|
||||
, Capture
|
||||
( Capture
|
||||
, Get
|
||||
, Handler
|
||||
, MimeRender (..)
|
||||
, Raw
|
||||
, ServerError (..)
|
||||
, ServerT
|
||||
, Tagged (..)
|
||||
, err404
|
||||
, err500
|
||||
, hoistServer
|
||||
, runHandler
|
||||
, serve
|
||||
, serveDirectoryWebApp
|
||||
, (:<|>) (..)
|
||||
, (:>)
|
||||
, pattern MkHandler
|
||||
@@ -48,30 +49,30 @@ 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.DB (DB, DayFile (..))
|
||||
import Yore.Download (downloadInto)
|
||||
import Yore.Error (Error (..))
|
||||
import Yore.Schedule (schedule)
|
||||
import Yore.Scrape (Issue (..), getIssuesByDay)
|
||||
import Yore.Servant (GetSendfile, HTML, Sendfile (..))
|
||||
import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
|
||||
|
||||
import Data.Fixed (Pico)
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
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
|
||||
, yoreStaticDir :: f =@@ FilePath ? "./static"
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
@@ -81,34 +82,69 @@ deriving instance Show Config
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
Log.setup
|
||||
|
||||
cfg <-
|
||||
Envy.load @ConfigT >>= \case
|
||||
Left err -> do
|
||||
Log.error $ printf "failed to read config: %s" err
|
||||
Left errs -> do
|
||||
forM_ errs $ Log.error . printf "failed to read config: %s"
|
||||
exitFailure
|
||||
Right c ->
|
||||
pure c
|
||||
|
||||
let
|
||||
db <- DB.initDB cfg.yoreDb
|
||||
|
||||
_ <- runExceptT $ doIndex cfg db
|
||||
|
||||
_ <- forkIO $ runIndexer cfg db
|
||||
runServer cfg db
|
||||
|
||||
runIndexer :: Config -> DB -> IO ()
|
||||
runIndexer cfg db =
|
||||
schedule shouldRunAt $ runExceptT $ doIndex cfg db
|
||||
where
|
||||
shouldRunAt zt = case localTimeOfDay $ zonedTimeToLocalTime zt of
|
||||
TimeOfDay 3 0 _ -> True
|
||||
_ -> False
|
||||
|
||||
doIndex :: Config -> DB -> ExceptT Error IO ()
|
||||
doIndex cfg db =
|
||||
catchE
|
||||
( DB.withTransaction db $ \conn -> do
|
||||
forM_ [0, 1, 2] $ \i -> do
|
||||
dayThen <- getTodayWithOffset (-100) i
|
||||
indexDay cfg dayThen conn
|
||||
)
|
||||
(Log.error . show)
|
||||
|
||||
runServer :: Config -> DB -> IO ()
|
||||
runServer cfg db =
|
||||
Warp.runSettings settings $ loggerMiddleware $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
|
||||
where
|
||||
settings =
|
||||
foldr
|
||||
($)
|
||||
Warp.defaultSettings
|
||||
[ Warp.setLogger logger
|
||||
, Warp.setPort cfg.yorePort
|
||||
[ 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 @API) $ hoistServer (Proxy @API) nt $ server cfg db
|
||||
where
|
||||
logger req status _ = do
|
||||
Log.info $
|
||||
printf
|
||||
"%d %s"
|
||||
(statusCode status)
|
||||
(requestLine req)
|
||||
logger :: Request -> Status -> Pico -> IO ()
|
||||
logger req status s = do
|
||||
Log.info $ printf "%d %s %ss" (statusCode status) (requestLine req) (formatMetric s)
|
||||
|
||||
loggerMiddleware :: Middleware
|
||||
loggerMiddleware app req respond = do
|
||||
begin <- getPOSIXTime
|
||||
app req $ \res -> do
|
||||
rr <- respond res
|
||||
end <- getPOSIXTime
|
||||
logger req (responseStatus res) (nominalDiffTimeToSeconds (end - begin))
|
||||
pure rr
|
||||
|
||||
onException mbReq ex = do
|
||||
Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex)
|
||||
|
||||
requestLine :: Request -> String
|
||||
requestLine req =
|
||||
@@ -117,8 +153,17 @@ main = do
|
||||
(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)
|
||||
formatMetric :: Pico -> String
|
||||
formatMetric x = go (-9) prefixes
|
||||
where
|
||||
prefixes = ["p", "n", "u", "m", "", "k", "M", "G"]
|
||||
|
||||
go :: Int -> [String] -> String
|
||||
go _ [] = show x
|
||||
go e (p : ps)
|
||||
| x < 10 ^^ e =
|
||||
show @Int (floor $ x * 10 ^^ (-e + 3)) ++ p
|
||||
| otherwise = go (e + 3) ps
|
||||
|
||||
nt :: ExceptT Error IO a -> Handler a
|
||||
nt action = MkHandler $ do
|
||||
@@ -130,11 +175,6 @@ nt action = MkHandler $ do
|
||||
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 ->
|
||||
@@ -149,39 +189,39 @@ toServerError = \case
|
||||
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
|
||||
type API =
|
||||
Get '[HTML] RootModel
|
||||
:<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel
|
||||
:<|> "static" :> Raw
|
||||
:<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> GetSendfile
|
||||
|
||||
server :: Config -> DB.DB -> ServerT API (ExceptT Error IO)
|
||||
server cfg db = rootR :<|> todayR :<|> apiTodayR
|
||||
server :: Config -> DB -> ServerT API (ExceptT Error IO)
|
||||
server cfg db = rootR :<|> todayR :<|> staticR :<|> 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
|
||||
dateThen <- getTodayWithOffset (-100) 0
|
||||
count <- DB.withConn db $ DB.getNumberOfIssues dateThen
|
||||
dayFile <- 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
|
||||
staticR = serveDirectoryWebApp cfg.yoreStaticDir
|
||||
|
||||
apiTodayR issue = do
|
||||
dateThen <- getTodayWithOffset (-100) 0
|
||||
dayFile <- 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
|
||||
pure
|
||||
Sendfile
|
||||
{ headers =
|
||||
[ ("content-type", "application/pdf")
|
||||
, ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight)
|
||||
]
|
||||
, path =
|
||||
fullPath
|
||||
}
|
||||
|
||||
data RootModel = RootModel Day DB.DayFile Int Int
|
||||
|
||||
@@ -203,7 +243,7 @@ instance MimeRender HTML RootModel where
|
||||
H.iframe ! A.src (H.toValue url) ! A.class_ "content" $ mempty
|
||||
where
|
||||
url :: String
|
||||
url = printf "/api/today/issue/%d/fz.pdf" issue
|
||||
url = printf "/static/pdfjs-5.7.284-dist/web/viewer.html?file=/api/today/issue/%d/fz.pdf#zoom=page-width" issue
|
||||
|
||||
(y, m, d) = toGregorian dateThen
|
||||
|
||||
@@ -217,11 +257,31 @@ instance MimeRender HTML RootModel where
|
||||
|
||||
-- Utils
|
||||
|
||||
data HTML
|
||||
getTodayWithOffset :: Integer -> Integer -> ExceptT Error IO Day
|
||||
getTodayWithOffset yearOffset dayOffset =
|
||||
ExceptT $
|
||||
first (GenericError . (Text.pack (printf "can't go back %d years and go forward %d days: " (-yearOffset) dayOffset) <>))
|
||||
. addYears yearOffset
|
||||
. addDays dayOffset
|
||||
<$> getCurrentDay
|
||||
|
||||
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
|
||||
indexDay :: Config -> Day -> Opium.Connection -> ExceptT Error IO ()
|
||||
indexDay cfg dayThen conn = do
|
||||
-- Transaction-level lock released automatically after transaction
|
||||
DB.lift $ Opium.execute_ "SELECT pg_advisory_xact_lock(42);" conn
|
||||
mbDi <- DB.readDayIndex dayThen conn
|
||||
case mbDi of
|
||||
Just _ ->
|
||||
Log.info $ printf "index for %s already exists." (show dayThen)
|
||||
Nothing -> do
|
||||
Log.info $ printf "scraping issues for %s" (show dayThen)
|
||||
issues <- liftIO $ getIssuesByDay dayThen
|
||||
paths <- forM issues $ \issue -> do
|
||||
Log.info $ printf "downloading %s" issue.url
|
||||
path <- downloadInto cfg.yoreDownloadDir issue.url
|
||||
pure (issue.label, path)
|
||||
Log.info "creating DB entries"
|
||||
dayIndex <- DB.createDayIndex dayThen conn
|
||||
forM_ paths $ \(text, url) ->
|
||||
DB.createDayFile dayIndex.day_index_id text url conn
|
||||
Log.info "done."
|
||||
|
||||
@@ -1,3 +1,8 @@
|
||||
\restrict CAC30PXzQJosjH02Spia1vzj9Ui3LB1Cq2HI8r0A4eu33HP8ngxbbM2SzRfTj0c
|
||||
|
||||
-- Dumped from database version 17.6
|
||||
-- Dumped by pg_dump version 17.6
|
||||
|
||||
SET statement_timeout = 0;
|
||||
SET lock_timeout = 0;
|
||||
SET idle_in_transaction_session_timeout = 0;
|
||||
@@ -124,6 +129,8 @@ ALTER TABLE ONLY yore.day_file
|
||||
-- PostgreSQL database dump complete
|
||||
--
|
||||
|
||||
\unrestrict CAC30PXzQJosjH02Spia1vzj9Ui3LB1Cq2HI8r0A4eu33HP8ngxbbM2SzRfTj0c
|
||||
|
||||
|
||||
--
|
||||
-- Dbmate schema migrations
|
||||
|
||||
Generated
+7
-7
@@ -40,11 +40,11 @@
|
||||
},
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1752536923,
|
||||
"narHash": "sha256-fdgPZR7VFSSRIQKOJLcs3qCJBWM64Uak0gAGtWTYAd8=",
|
||||
"lastModified": 1758518877,
|
||||
"narHash": "sha256-1K1c6vNr/N1PfM77DqKINXQ/oCxA0W1ZJ80sfNzWu0w=",
|
||||
"owner": "nixos",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "c665e4d918eda5d78a175ed8d300809c44932160",
|
||||
"rev": "033cc13ab4c1a60b3527b242755aa625001ff1f9",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
@@ -64,11 +64,11 @@
|
||||
]
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1756064767,
|
||||
"narHash": "sha256-SaJK9VYc/oF5aBSMSW+We8TggER4+uTAHvc2ztnLpYo=",
|
||||
"lastModified": 1759790870,
|
||||
"narHash": "sha256-rEsaO38v2wvAThPzgbYPgnv29mu6GxTYLjgci3GYaO4=",
|
||||
"ref": "main",
|
||||
"rev": "af16429d827816cf9bec69026e13f50acc3d2691",
|
||||
"revCount": 65,
|
||||
"rev": "4db509c1b52ee7b5012abfef5e11e62beab27a16",
|
||||
"revCount": 66,
|
||||
"type": "git",
|
||||
"url": "https://git.pbrinkmeier.de/paul/opium"
|
||||
},
|
||||
|
||||
@@ -26,17 +26,24 @@
|
||||
};
|
||||
|
||||
# For building the package, we use only the files not ignored by Git as inputs.
|
||||
# Also, flake.nix and flake.lock are not included to avoid rebuilds when
|
||||
# Also, flake.nix, flake.lock and .gitea are not included to avoid rebuilds when
|
||||
# working on them.
|
||||
src = pkgs.lib.cleanSourceWith {
|
||||
src = gitignore.lib.gitignoreSource ./.;
|
||||
filter = path: type: builtins.elem (builtins.baseNameOf path) [ "flake.nix" "flake.lock" ];
|
||||
src = ./.;
|
||||
filter = gitignore.lib.gitignoreFilterWith {
|
||||
basePath = ./.;
|
||||
extraRules = ''
|
||||
flake.nix
|
||||
flake.lock
|
||||
.gitea
|
||||
'';
|
||||
};
|
||||
};
|
||||
|
||||
yore = pkgs.lib.pipe
|
||||
# The basic package
|
||||
(pkgs.haskellPackages.developPackage {
|
||||
root = ./.;
|
||||
root = src;
|
||||
overrides = addOpium;
|
||||
})
|
||||
# And some build configuration.
|
||||
@@ -51,16 +58,51 @@
|
||||
# Return only the bin folder to curb image size
|
||||
compose.justStaticExecutables
|
||||
];
|
||||
|
||||
image =
|
||||
pkgs.dockerTools.buildImage {
|
||||
name = "git.pbrinkmeier.de/paul/yore";
|
||||
tag = yore.version;
|
||||
copyToRoot = [ pkgs.cacert ];
|
||||
config = {
|
||||
Cmd = [ "${entrypoint}/bin/run" ];
|
||||
StopSignal = "SIGINT";
|
||||
};
|
||||
};
|
||||
|
||||
entrypoint = pkgs.writeShellApplication {
|
||||
name = "run";
|
||||
runtimeInputs = [ pkgs.coreutils pkgs.dbmate yore ];
|
||||
text = ''
|
||||
set -Eeuo pipefail
|
||||
|
||||
mkdir -p "''${YORE_DBMATE_DIR}"
|
||||
TMPDIR=$(mktemp -dp "''${YORE_DBMATE_DIR}")
|
||||
mkdir -p "''${TMPDIR}/db"
|
||||
cp -r ${./db}/* "''${TMPDIR}/db"
|
||||
cd "''${TMPDIR}"
|
||||
dbmate up
|
||||
chmod +w -R "''${TMPDIR}"
|
||||
rm -rf "''${TMPDIR}"
|
||||
|
||||
echo ${./static}
|
||||
export YORE_STATIC_DIR=${./static}
|
||||
|
||||
# Replace bash and inherit PID 1
|
||||
cd /
|
||||
exec yore
|
||||
'';
|
||||
};
|
||||
in {
|
||||
packages = rec {
|
||||
docker =
|
||||
pkgs.dockerTools.buildImage {
|
||||
name = "git.pbrinkmeier.de/paul/yore";
|
||||
tag = yore.version;
|
||||
config.Cmd = [ "${yore}/bin/yore" ];
|
||||
};
|
||||
|
||||
default = yore;
|
||||
inherit yore image;
|
||||
yore-meta = pkgs.runCommand "yore-meta" {} ''
|
||||
mkdir -p $out
|
||||
echo -n ${yore.version} > $out/version
|
||||
echo -n ${image.drvAttrs.imageName}:${image.drvAttrs.imageTag} > $out/image-tag
|
||||
'';
|
||||
|
||||
|
||||
opium_ = opium.packages.${system}.opium;
|
||||
};
|
||||
@@ -82,5 +124,11 @@
|
||||
overrides = addOpium;
|
||||
}).env;
|
||||
};
|
||||
apps = {
|
||||
crane = {
|
||||
type = "app";
|
||||
program = "${pkgs.crane}/bin/crane";
|
||||
};
|
||||
};
|
||||
});
|
||||
}
|
||||
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 152 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 190 KiB |
@@ -1,3 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
YORE_DB="host=localhost port=${DB_PORT} user=${DB_USER} dbname=${DB_DBNAME}" cabal repl exe:yore
|
||||
@@ -26,4 +26,6 @@ fi
|
||||
|
||||
DATABASE_URL="postgres://${DB_USER}@localhost:${DB_PORT}/${DB_DBNAME}?sslmode=disable" dbmate up
|
||||
|
||||
export YORE_DB="host=localhost port=${DB_PORT} user=${DB_USER} dbname=${DB_DBNAME}"
|
||||
|
||||
"$@"
|
||||
|
||||
+12
-4
@@ -56,13 +56,13 @@ type t ? d = Optional t d
|
||||
load
|
||||
:: forall (m :: ConfigVariant -> Type)
|
||||
. (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value)))
|
||||
=> IO (Either String (m Value))
|
||||
=> IO (Either [String] (m Value))
|
||||
load = do
|
||||
env <- getEnvironment
|
||||
pure $ to <$> gFromEnv @(Rep (m Spec)) @(Rep (m Value)) Proxy env
|
||||
|
||||
class GFromEnv spec value where
|
||||
gFromEnv :: Proxy (spec c) -> [(String, String)] -> Either String (value c)
|
||||
gFromEnv :: Proxy (spec c) -> [(String, String)] -> Either [String] (value c)
|
||||
|
||||
instance
|
||||
(GFromEnv i o)
|
||||
@@ -77,7 +77,15 @@ instance
|
||||
gFromEnv Proxy env = M1 <$> gFromEnv @i @o Proxy env
|
||||
|
||||
instance (GFromEnv i1 o1, GFromEnv i2 o2) => GFromEnv (i1 :*: i2) (o1 :*: o2) where
|
||||
gFromEnv Proxy env = (:*:) <$> gFromEnv @i1 @o1 Proxy env <*> gFromEnv @i2 @o2 Proxy env
|
||||
gFromEnv Proxy env =
|
||||
case (eLhs, eRhs) of
|
||||
(Left errs1, Right _) -> Left errs1
|
||||
(Right _, Left errs2) -> Left errs2
|
||||
(Left errs1, Left errs2) -> Left $ errs1 ++ errs2
|
||||
(Right lhs, Right rhs) -> Right $ lhs :*: rhs
|
||||
where
|
||||
eLhs = gFromEnv @i1 @o1 Proxy env
|
||||
eRhs = gFromEnv @i2 @o2 Proxy env
|
||||
|
||||
instance
|
||||
(KnownSymbol sym, EnvVarSpec s t)
|
||||
@@ -86,7 +94,7 @@ instance
|
||||
(M1 S meta2 (Rec0 t))
|
||||
where
|
||||
gFromEnv Proxy env =
|
||||
M1 . K1 <$> decodeEnvVar @s @t Proxy varName (lookup varName env)
|
||||
M1 . K1 <$> first (: []) (decodeEnvVar @s @t Proxy varName (lookup varName env))
|
||||
where
|
||||
varName = selectorNameToEnvVarName $ symbolVal $ Proxy @sym
|
||||
|
||||
|
||||
+49
-20
@@ -9,6 +9,7 @@ module Yore.DB
|
||||
, Error (..)
|
||||
, initDB
|
||||
, withConn
|
||||
, withTransaction
|
||||
, DayIndex (..)
|
||||
, DayFile (..)
|
||||
, createDayFile
|
||||
@@ -17,9 +18,11 @@ module Yore.DB
|
||||
, readDayPaths
|
||||
, getDayFileByIssue
|
||||
, getNumberOfIssues
|
||||
, lift
|
||||
) where
|
||||
|
||||
import Control.Concurrent (getNumCapabilities)
|
||||
import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT, throwE)
|
||||
import Data.Functor.Identity (Identity (..))
|
||||
import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
|
||||
import Data.Text (Text)
|
||||
@@ -28,6 +31,7 @@ import GHC.Generics (Generic)
|
||||
|
||||
import qualified Database.PostgreSQL.Opium as Opium
|
||||
|
||||
import Data.Bifunctor (Bifunctor (..))
|
||||
import Yore.Error (Error (..))
|
||||
|
||||
newtype DB = DB (Pool (Either Opium.ConnectionError Opium.Connection))
|
||||
@@ -45,13 +49,35 @@ initDB connString = do
|
||||
maxResources
|
||||
)
|
||||
|
||||
withConn :: DB -> (Opium.Connection -> IO (Either Opium.Error a)) -> IO (Either Error a)
|
||||
-- TODO: This should probably also do something like bracket...
|
||||
-- For now let's assume no exceptions are thrown in f.
|
||||
withConn :: DB -> (Opium.Connection -> ExceptT Error IO a) -> ExceptT Error IO a
|
||||
withConn (DB connPool) f =
|
||||
withResource connPool $ \case
|
||||
ExceptT $ withResource connPool $ \case
|
||||
Left connectionError ->
|
||||
pure $ Left $ ConnectionError connectionError
|
||||
Right conn ->
|
||||
either (Left . DBError) Right <$> f conn
|
||||
runExceptT $ f conn
|
||||
|
||||
withTransaction :: DB -> (Opium.Connection -> ExceptT Error IO a) -> ExceptT Error IO a
|
||||
withTransaction db f =
|
||||
withConn db $ \conn ->
|
||||
( do
|
||||
lift $ Opium.execute_ "BEGIN" conn
|
||||
x <- f conn
|
||||
lift $ Opium.execute_ "COMMIT" conn
|
||||
pure x
|
||||
)
|
||||
`catchE` ( \err -> do
|
||||
-- rollback open transactions and release transaction level locks...
|
||||
lift $ Opium.execute_ "ROLLBACK" conn
|
||||
-- ...then rethrow the error so the app can handle it too.
|
||||
throwE err
|
||||
)
|
||||
|
||||
lift :: IO (Either Opium.Error a) -> ExceptT Error IO a
|
||||
lift f =
|
||||
ExceptT $ first DBError <$> f
|
||||
|
||||
data DayIndex = DayIndex
|
||||
{ day_index_id :: Int
|
||||
@@ -72,44 +98,47 @@ newtype CountResult = CountResult
|
||||
}
|
||||
deriving (Show, Generic, Opium.FromRow)
|
||||
|
||||
createDayIndex :: Day -> Opium.Connection -> IO (Either Opium.Error DayIndex)
|
||||
createDayIndex :: Day -> Opium.Connection -> ExceptT Error IO DayIndex
|
||||
createDayIndex date =
|
||||
ex runIdentity
|
||||
. Opium.fetch
|
||||
"INSERT INTO yore.day_index (day) VALUES ($1) RETURNING *"
|
||||
(Identity date)
|
||||
|
||||
createDayFile :: Int -> Text -> FilePath -> Opium.Connection -> IO (Either Opium.Error ())
|
||||
createDayFile :: Int -> Text -> FilePath -> Opium.Connection -> ExceptT Error IO ()
|
||||
createDayFile dayId label path =
|
||||
Opium.execute
|
||||
"INSERT INTO yore.day_file (day_index_id, label, relative_path) VALUES ($1, $2, $3)"
|
||||
(dayId, label, path)
|
||||
lift
|
||||
. Opium.execute
|
||||
"INSERT INTO yore.day_file (day_index_id, label, relative_path) VALUES ($1, $2, $3)"
|
||||
(dayId, label, path)
|
||||
|
||||
readDayIndex :: Day -> Opium.Connection -> IO (Either Opium.Error (Maybe DayIndex))
|
||||
readDayIndex :: Day -> Opium.Connection -> ExceptT Error IO (Maybe DayIndex)
|
||||
readDayIndex date =
|
||||
Opium.fetch
|
||||
"SELECT * FROM yore.day_index WHERE day = $1"
|
||||
(Identity date)
|
||||
lift
|
||||
. Opium.fetch
|
||||
"SELECT * FROM yore.day_index WHERE day = $1"
|
||||
(Identity date)
|
||||
|
||||
readDayPaths :: Day -> Opium.Connection -> IO (Either Opium.Error [(DayIndex, DayFile)])
|
||||
readDayPaths :: Day -> Opium.Connection -> ExceptT Error IO [(DayIndex, DayFile)]
|
||||
readDayPaths date =
|
||||
Opium.fetch
|
||||
"SELECT * FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1"
|
||||
(Identity date)
|
||||
lift
|
||||
. Opium.fetch
|
||||
"SELECT * FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1"
|
||||
(Identity date)
|
||||
|
||||
getDayFileByIssue :: Day -> Int -> Opium.Connection -> IO (Either Opium.Error DayFile)
|
||||
getDayFileByIssue :: Day -> Int -> Opium.Connection -> ExceptT Error IO DayFile
|
||||
getDayFileByIssue date issue =
|
||||
ex runIdentity
|
||||
. Opium.fetch
|
||||
"SELECT yore.day_file.* FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1 ORDER BY day_file_id LIMIT 1 OFFSET $2"
|
||||
(date, issue)
|
||||
|
||||
getNumberOfIssues :: Day -> Opium.Connection -> IO (Either Opium.Error Int)
|
||||
getNumberOfIssues :: Day -> Opium.Connection -> ExceptT Error IO Int
|
||||
getNumberOfIssues date =
|
||||
ex (count . runIdentity)
|
||||
. Opium.fetch
|
||||
"SELECT count(*) FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1"
|
||||
(Identity date)
|
||||
|
||||
ex :: (a -> b) -> IO (Either e a) -> IO (Either e b)
|
||||
ex = fmap . fmap
|
||||
ex :: (a -> b) -> IO (Either Opium.Error a) -> ExceptT Error IO b
|
||||
ex f = fmap f . lift
|
||||
|
||||
+19
-8
@@ -2,7 +2,8 @@
|
||||
|
||||
module Yore.Download (downloadInto) where
|
||||
|
||||
import Control.Monad (guard)
|
||||
import Control.Exception (Exception, IOException, catch)
|
||||
import Control.Monad.Trans.Except (ExceptT (..))
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Req hiding (queryParam)
|
||||
@@ -14,6 +15,8 @@ import qualified Data.Text as Text
|
||||
import qualified Data.UUID.V4 as UUID
|
||||
import qualified Text.URI as URI
|
||||
|
||||
import Yore.Error (Error (..))
|
||||
|
||||
-- | Download a URL and save it to a directory.
|
||||
-- Returns the path of the downloaded file relative to the directory.
|
||||
downloadInto
|
||||
@@ -21,22 +24,30 @@ downloadInto
|
||||
-- ^ Directory where to store the file.
|
||||
-> Text
|
||||
-- ^ The URL to download.
|
||||
-> IO FilePath
|
||||
downloadInto downloadDir textUrl = download >>= save
|
||||
-> ExceptT Error IO FilePath
|
||||
downloadInto downloadDir textUrl =
|
||||
download >>= save
|
||||
where
|
||||
download :: IO LBS.ByteString
|
||||
download = do
|
||||
download :: ExceptT Error IO LBS.ByteString
|
||||
download = toExceptT (handle @HttpException) $ do
|
||||
uri <- URI.mkURI textUrl
|
||||
let (url, opts) = fromJust $ useHttpsURI uri
|
||||
res <- runReq defaultHttpConfig $ req GET url NoReqBody lbsResponse opts
|
||||
guard $ responseStatusCode res == 200
|
||||
pure $ responseBody res
|
||||
|
||||
save :: LBS.ByteString -> IO FilePath
|
||||
save contents = do
|
||||
save :: LBS.ByteString -> ExceptT Error IO FilePath
|
||||
save contents = toExceptT (handle @IOException) $ do
|
||||
let suffix = takeExtension $ Text.unpack textUrl
|
||||
uuid <- UUID.nextRandom
|
||||
let fullPath = downloadDir </> show uuid <.> suffix
|
||||
createDirectoryIfMissing True downloadDir
|
||||
LBS.writeFile fullPath contents
|
||||
pure $ makeRelative downloadDir fullPath
|
||||
|
||||
toExceptT :: (Exception e) => (e -> Error) -> IO a -> ExceptT Error IO a
|
||||
toExceptT showException f =
|
||||
ExceptT $ (Right <$> f) `catch` (pure . Left . showException)
|
||||
|
||||
handle :: (Show e) => e -> Error
|
||||
handle =
|
||||
GenericError . Text.pack . show
|
||||
|
||||
@@ -1,24 +0,0 @@
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Yore.Index (createEntries) where
|
||||
|
||||
import Control.Exception (Exception, throwIO)
|
||||
import Control.Monad (forM_)
|
||||
import Data.Text (Text)
|
||||
import Data.Time (Day)
|
||||
|
||||
import qualified Database.PostgreSQL.Opium as Opium
|
||||
|
||||
import qualified Yore.DB as DB
|
||||
|
||||
createEntries :: Day -> [(Text, FilePath)] -> Opium.Connection -> IO ()
|
||||
createEntries date urls conn = do
|
||||
confidently $ Opium.execute_ "BEGIN" conn
|
||||
dayIndex <- confidently $ DB.createDayIndex date conn
|
||||
forM_ urls $ \(text, url) ->
|
||||
confidently $ DB.createDayFile dayIndex.day_index_id text url conn
|
||||
confidently $ Opium.execute_ "COMMIT" conn
|
||||
|
||||
confidently :: (Exception e) => IO (Either e a) -> IO a
|
||||
confidently action = action >>= either throwIO pure
|
||||
+14
-6
@@ -1,21 +1,29 @@
|
||||
module Yore.Log (Yore.Log.error, info) where
|
||||
module Yore.Log (Yore.Log.error, info, setup) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO (..))
|
||||
import Data.Time (ZonedTime, getZonedTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack)
|
||||
import System.IO (BufferMode (..), hSetBuffering, stdout)
|
||||
import Text.Printf (printf)
|
||||
|
||||
info :: (HasCallStack) => String -> IO ()
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.IO as TextIO
|
||||
|
||||
setup :: IO ()
|
||||
setup = hSetBuffering stdout LineBuffering
|
||||
|
||||
info :: (HasCallStack, MonadIO m) => String -> m ()
|
||||
info = doLog "INF"
|
||||
|
||||
error :: (HasCallStack) => String -> IO ()
|
||||
error :: (HasCallStack, MonadIO m) => String -> m ()
|
||||
error = doLog "ERR"
|
||||
|
||||
doLog :: (HasCallStack) => String -> String -> IO ()
|
||||
doLog level msg = do
|
||||
doLog :: (HasCallStack, MonadIO m) => String -> String -> m ()
|
||||
doLog level msg = liftIO $ do
|
||||
now <- getZonedTime
|
||||
let location = getLocation $ getCallStack callStack
|
||||
printf "(%s) (%s) (%s) %s\n" (iso8601Show now) level location msg
|
||||
TextIO.putStrLn $ Text.pack $ printf "(%s) (%s) (%s) %s" (iso8601Show now) level location msg
|
||||
where
|
||||
getLocation :: [(String, SrcLoc)] -> String
|
||||
-- First entry is always a function from this module, skip it
|
||||
|
||||
@@ -1,59 +0,0 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Yore.Repl (connect, exec, getToday, indexDay, addYears) where
|
||||
|
||||
import Control.Exception (bracket, throwIO)
|
||||
import Control.Monad (forM)
|
||||
import Data.Time (Day, getZonedTime, localDay, zonedTimeToLocalTime)
|
||||
import Text.Printf (printf)
|
||||
|
||||
import qualified Database.PostgreSQL.Opium as Opium
|
||||
|
||||
import Yore.DB (DayIndex)
|
||||
import Yore.Download (downloadInto)
|
||||
import Yore.Index (createEntries)
|
||||
import Yore.Scrape (Issue (..), getIssuesByDay)
|
||||
import Yore.Time (addYears)
|
||||
|
||||
import qualified Yore.DB as DB
|
||||
|
||||
connect :: IO Opium.Connection
|
||||
connect =
|
||||
Opium.connect "host=localhost port=5433 user=yore-test" >>= \case
|
||||
Left e -> error $ show e
|
||||
Right c -> pure c
|
||||
|
||||
exec :: (Opium.Connection -> IO a) -> IO a
|
||||
exec = bracket connect Opium.close
|
||||
|
||||
getToday :: IO [Issue]
|
||||
getToday = do
|
||||
now <- getZonedTime
|
||||
print now
|
||||
let currentDay = localDay $ zonedTimeToLocalTime now
|
||||
case addYears (-100) currentDay of
|
||||
Right then_ ->
|
||||
getIssuesByDay then_
|
||||
Left _ ->
|
||||
pure []
|
||||
|
||||
indexDay :: Day -> IO ()
|
||||
indexDay date = exec $ \conn -> do
|
||||
either throwIO pure =<< Opium.execute_ "SELECT pg_advisory_lock(42);" conn
|
||||
printf "Checking whether %s already exists...\n" (show date)
|
||||
mbDi <- either throwIO pure =<< DB.readDayIndex date conn
|
||||
case mbDi of
|
||||
Just (_ :: DayIndex) ->
|
||||
putStrLn "Nothing to do."
|
||||
Nothing -> do
|
||||
putStrLn "Retrieving URLs..."
|
||||
issues <- getIssuesByDay date
|
||||
paths <- forM issues $ \issue -> do
|
||||
printf "Downloading %s...\n" issue.url
|
||||
path <- downloadInto "./download" issue.url
|
||||
pure (issue.label, path)
|
||||
putStrLn "Creating DB entries..."
|
||||
createEntries date paths conn
|
||||
putStrLn "Done."
|
||||
@@ -0,0 +1,22 @@
|
||||
module Yore.Schedule (schedule) where
|
||||
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Monad (when)
|
||||
import Data.Functor (($>))
|
||||
import Data.Time (ZonedTime, getZonedTime, nominalDiffTimeToSeconds, secondsToNominalDiffTime)
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
|
||||
schedule :: (ZonedTime -> Bool) -> IO a -> IO ()
|
||||
schedule shouldRunAt f = everyMinute $ \now -> when (shouldRunAt now) (f $> ())
|
||||
|
||||
everyMinute :: (ZonedTime -> IO ()) -> IO ()
|
||||
everyMinute f = do
|
||||
-- Use POSIX time to avoid having to handle leap seconds
|
||||
now <- getPOSIXTime
|
||||
let posixSeconds :: Int
|
||||
posixSeconds = floor $ nominalDiffTimeToSeconds now
|
||||
lastFullMinute = secondsToNominalDiffTime $ fromIntegral $ posixSeconds - posixSeconds `mod` 60
|
||||
secondsSinceLastFullMinute = now - lastFullMinute
|
||||
threadDelay $ ceiling $ (60 - secondsSinceLastFullMinute) * 1_000_000
|
||||
_ <- forkIO $ f =<< getZonedTime
|
||||
everyMinute f
|
||||
+1
-1
@@ -112,7 +112,7 @@ showpdfRequest (y, m, d) =
|
||||
NoReqBody
|
||||
bsResponse
|
||||
( formToQuery
|
||||
[ ("cmd" :: Text, "showpdf")
|
||||
[ ("cmd" :: Text, "showpdfjs")
|
||||
, ("year", y)
|
||||
, ("month", m)
|
||||
, ("day", d)
|
||||
|
||||
@@ -0,0 +1,38 @@
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Yore.Servant (GetSendfile, Sendfile (..), HTML) where
|
||||
|
||||
import Network.HTTP.Media ((//), (/:))
|
||||
import Network.HTTP.Types (ResponseHeaders, status200)
|
||||
import Network.Wai (responseFile)
|
||||
import Servant (Accept (..), HasServer (..))
|
||||
import Servant.Server.Internal.Delayed (runAction)
|
||||
import Servant.Server.Internal.RouteResult (RouteResult (..))
|
||||
import Servant.Server.Internal.Router (Router' (..))
|
||||
|
||||
-- | Servant route type that responds with a file using @sendfile@.
|
||||
data GetSendfile
|
||||
|
||||
data Sendfile = Sendfile
|
||||
{ headers :: ResponseHeaders
|
||||
-- ^ The headers to send along with the file, e.g. @content-type@ or cache information.
|
||||
, path :: FilePath
|
||||
-- ^ The file to respond with.
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance HasServer GetSendfile context where
|
||||
type ServerT GetSendfile m = m Sendfile
|
||||
|
||||
hoistServerWithContext _ _ nt = nt
|
||||
|
||||
route _ _ action = RawRouter $ \env request respond ->
|
||||
runAction action env request respond $ \sendfile ->
|
||||
Route $ responseFile status200 sendfile.headers sendfile.path Nothing
|
||||
|
||||
data HTML
|
||||
|
||||
instance Accept HTML where
|
||||
contentType _ = "text" // "html" /: ("charset", "utf-8")
|
||||
Vendored
BIN
Binary file not shown.
@@ -0,0 +1,177 @@
|
||||
|
||||
Apache License
|
||||
Version 2.0, January 2004
|
||||
http://www.apache.org/licenses/
|
||||
|
||||
TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
|
||||
|
||||
1. Definitions.
|
||||
|
||||
"License" shall mean the terms and conditions for use, reproduction,
|
||||
and distribution as defined by Sections 1 through 9 of this document.
|
||||
|
||||
"Licensor" shall mean the copyright owner or entity authorized by
|
||||
the copyright owner that is granting the License.
|
||||
|
||||
"Legal Entity" shall mean the union of the acting entity and all
|
||||
other entities that control, are controlled by, or are under common
|
||||
control with that entity. For the purposes of this definition,
|
||||
"control" means (i) the power, direct or indirect, to cause the
|
||||
direction or management of such entity, whether by contract or
|
||||
otherwise, or (ii) ownership of fifty percent (50%) or more of the
|
||||
outstanding shares, or (iii) beneficial ownership of such entity.
|
||||
|
||||
"You" (or "Your") shall mean an individual or Legal Entity
|
||||
exercising permissions granted by this License.
|
||||
|
||||
"Source" form shall mean the preferred form for making modifications,
|
||||
including but not limited to software source code, documentation
|
||||
source, and configuration files.
|
||||
|
||||
"Object" form shall mean any form resulting from mechanical
|
||||
transformation or translation of a Source form, including but
|
||||
not limited to compiled object code, generated documentation,
|
||||
and conversions to other media types.
|
||||
|
||||
"Work" shall mean the work of authorship, whether in Source or
|
||||
Object form, made available under the License, as indicated by a
|
||||
copyright notice that is included in or attached to the work
|
||||
(an example is provided in the Appendix below).
|
||||
|
||||
"Derivative Works" shall mean any work, whether in Source or Object
|
||||
form, that is based on (or derived from) the Work and for which the
|
||||
editorial revisions, annotations, elaborations, or other modifications
|
||||
represent, as a whole, an original work of authorship. For the purposes
|
||||
of this License, Derivative Works shall not include works that remain
|
||||
separable from, or merely link (or bind by name) to the interfaces of,
|
||||
the Work and Derivative Works thereof.
|
||||
|
||||
"Contribution" shall mean any work of authorship, including
|
||||
the original version of the Work and any modifications or additions
|
||||
to that Work or Derivative Works thereof, that is intentionally
|
||||
submitted to Licensor for inclusion in the Work by the copyright owner
|
||||
or by an individual or Legal Entity authorized to submit on behalf of
|
||||
the copyright owner. For the purposes of this definition, "submitted"
|
||||
means any form of electronic, verbal, or written communication sent
|
||||
to the Licensor or its representatives, including but not limited to
|
||||
communication on electronic mailing lists, source code control systems,
|
||||
and issue tracking systems that are managed by, or on behalf of, the
|
||||
Licensor for the purpose of discussing and improving the Work, but
|
||||
excluding communication that is conspicuously marked or otherwise
|
||||
designated in writing by the copyright owner as "Not a Contribution."
|
||||
|
||||
"Contributor" shall mean Licensor and any individual or Legal Entity
|
||||
on behalf of whom a Contribution has been received by Licensor and
|
||||
subsequently incorporated within the Work.
|
||||
|
||||
2. Grant of Copyright License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
copyright license to reproduce, prepare Derivative Works of,
|
||||
publicly display, publicly perform, sublicense, and distribute the
|
||||
Work and such Derivative Works in Source or Object form.
|
||||
|
||||
3. Grant of Patent License. Subject to the terms and conditions of
|
||||
this License, each Contributor hereby grants to You a perpetual,
|
||||
worldwide, non-exclusive, no-charge, royalty-free, irrevocable
|
||||
(except as stated in this section) patent license to make, have made,
|
||||
use, offer to sell, sell, import, and otherwise transfer the Work,
|
||||
where such license applies only to those patent claims licensable
|
||||
by such Contributor that are necessarily infringed by their
|
||||
Contribution(s) alone or by combination of their Contribution(s)
|
||||
with the Work to which such Contribution(s) was submitted. If You
|
||||
institute patent litigation against any entity (including a
|
||||
cross-claim or counterclaim in a lawsuit) alleging that the Work
|
||||
or a Contribution incorporated within the Work constitutes direct
|
||||
or contributory patent infringement, then any patent licenses
|
||||
granted to You under this License for that Work shall terminate
|
||||
as of the date such litigation is filed.
|
||||
|
||||
4. Redistribution. You may reproduce and distribute copies of the
|
||||
Work or Derivative Works thereof in any medium, with or without
|
||||
modifications, and in Source or Object form, provided that You
|
||||
meet the following conditions:
|
||||
|
||||
(a) You must give any other recipients of the Work or
|
||||
Derivative Works a copy of this License; and
|
||||
|
||||
(b) You must cause any modified files to carry prominent notices
|
||||
stating that You changed the files; and
|
||||
|
||||
(c) You must retain, in the Source form of any Derivative Works
|
||||
that You distribute, all copyright, patent, trademark, and
|
||||
attribution notices from the Source form of the Work,
|
||||
excluding those notices that do not pertain to any part of
|
||||
the Derivative Works; and
|
||||
|
||||
(d) If the Work includes a "NOTICE" text file as part of its
|
||||
distribution, then any Derivative Works that You distribute must
|
||||
include a readable copy of the attribution notices contained
|
||||
within such NOTICE file, excluding those notices that do not
|
||||
pertain to any part of the Derivative Works, in at least one
|
||||
of the following places: within a NOTICE text file distributed
|
||||
as part of the Derivative Works; within the Source form or
|
||||
documentation, if provided along with the Derivative Works; or,
|
||||
within a display generated by the Derivative Works, if and
|
||||
wherever such third-party notices normally appear. The contents
|
||||
of the NOTICE file are for informational purposes only and
|
||||
do not modify the License. You may add Your own attribution
|
||||
notices within Derivative Works that You distribute, alongside
|
||||
or as an addendum to the NOTICE text from the Work, provided
|
||||
that such additional attribution notices cannot be construed
|
||||
as modifying the License.
|
||||
|
||||
You may add Your own copyright statement to Your modifications and
|
||||
may provide additional or different license terms and conditions
|
||||
for use, reproduction, or distribution of Your modifications, or
|
||||
for any such Derivative Works as a whole, provided Your use,
|
||||
reproduction, and distribution of the Work otherwise complies with
|
||||
the conditions stated in this License.
|
||||
|
||||
5. Submission of Contributions. Unless You explicitly state otherwise,
|
||||
any Contribution intentionally submitted for inclusion in the Work
|
||||
by You to the Licensor shall be under the terms and conditions of
|
||||
this License, without any additional terms or conditions.
|
||||
Notwithstanding the above, nothing herein shall supersede or modify
|
||||
the terms of any separate license agreement you may have executed
|
||||
with Licensor regarding such Contributions.
|
||||
|
||||
6. Trademarks. This License does not grant permission to use the trade
|
||||
names, trademarks, service marks, or product names of the Licensor,
|
||||
except as required for reasonable and customary use in describing the
|
||||
origin of the Work and reproducing the content of the NOTICE file.
|
||||
|
||||
7. Disclaimer of Warranty. Unless required by applicable law or
|
||||
agreed to in writing, Licensor provides the Work (and each
|
||||
Contributor provides its Contributions) on an "AS IS" BASIS,
|
||||
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
|
||||
implied, including, without limitation, any warranties or conditions
|
||||
of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
|
||||
PARTICULAR PURPOSE. You are solely responsible for determining the
|
||||
appropriateness of using or redistributing the Work and assume any
|
||||
risks associated with Your exercise of permissions under this License.
|
||||
|
||||
8. Limitation of Liability. In no event and under no legal theory,
|
||||
whether in tort (including negligence), contract, or otherwise,
|
||||
unless required by applicable law (such as deliberate and grossly
|
||||
negligent acts) or agreed to in writing, shall any Contributor be
|
||||
liable to You for damages, including any direct, indirect, special,
|
||||
incidental, or consequential damages of any character arising as a
|
||||
result of this License or out of the use or inability to use the
|
||||
Work (including but not limited to damages for loss of goodwill,
|
||||
work stoppage, computer failure or malfunction, or any and all
|
||||
other commercial damages or losses), even if such Contributor
|
||||
has been advised of the possibility of such damages.
|
||||
|
||||
9. Accepting Warranty or Additional Liability. While redistributing
|
||||
the Work or Derivative Works thereof, You may choose to offer,
|
||||
and charge a fee for, acceptance of support, warranty, indemnity,
|
||||
or other liability obligations and/or rights consistent with this
|
||||
License. However, in accepting such obligations, You may act only
|
||||
on Your own behalf and on Your sole responsibility, not on behalf
|
||||
of any other Contributor, and only if You agree to indemnify,
|
||||
defend, and hold each Contributor harmless for any liability
|
||||
incurred by, or claims asserted against, such Contributor by reason
|
||||
of your accepting any such warranty or additional liability.
|
||||
|
||||
END OF TERMS AND CONDITIONS
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,3 @@
|
||||
àRCopyright 1990-2009 Adobe Systems Incorporated.
|
||||
All rights reserved.
|
||||
See ./LICENSEáCNS2-H
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,3 @@
|
||||
àRCopyright 1990-2009 Adobe Systems Incorporated.
|
||||
All rights reserved.
|
||||
See ./LICENSEá ETen-B5-H` ^
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -0,0 +1,4 @@
|
||||
àRCopyright 1990-2009 Adobe Systems Incorporated.
|
||||
All rights reserved.
|
||||
See ./LICENSE!!�º]aX!!]`�21�> �p�z�$]‚�"R‚d�-Uƒ7�*„␍4„%�+ „Z „{�/…%…<�9K…b�1]†.�"‡‰`]‡,�"]ˆ
|
||||
�"]ˆh�"]‰F�"]Š$�"]‹�"]‹`�"]Œ>�"]��"]�z�"]ŽX�"]�6�"]��"]�r�"]‘P�"]’.�"]“�"]“j�"]”H�"]•&�"]–�"]–b�"]—@�"]˜�"]˜|�"]™Z�"]š8�"]›�"]›t�"]œR�"]�0�"]ž�"]žl�"]ŸJ�"] (�"]¡�"]¡d�"]¢B�"]£ �"X£~�']¤W�"]¥5�"]¦�"]¦q�"]§O�"]¨-�"]©�"]©i�"]ªG�"]«%�"]¬�"]¬a�"]?�"]®�"]®{�"]¯Y�"]°7�"]±�"]±s�"]²Q�"]³/�"]´␍�"]´k�"]µI�"]¶'�"]·�"]·c�"]¸A�"]¹�"]¹}�"]º[�"]»9
|
||||
Binary file not shown.
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user