24 Commits
Author SHA1 Message Date
Paul Brinkmeier 2dacd4f747 Use /tmp for running dbmate
deliver / deliver (push) Successful in 2m6s
2025-10-07 16:48:53 +02:00
paul 94ede9a168 Use SIGINT as container StopSignal
deliver / deliver (push) Failing after 20s
2025-10-07 13:47:12 +02:00
Paul Brinkmeier c38574e005 Add exec in entrypoint
deliver / deliver (push) Successful in 1m40s
2025-10-07 13:26:46 +02:00
Paul Brinkmeier 700d53fbb0 Update todo list 2025-10-07 13:09:24 +02:00
Paul Brinkmeier c5c11ed181 Don't buffer stdout
deliver / deliver (push) Successful in 1m36s
2025-10-07 12:53:14 +02:00
paul 36c9b880a7 Merge pull request 'Add entrypoint script and cacerts to image' (#2) from image-entry into main
Reviewed-on: #2
2025-10-07 12:50:53 +02:00
paul c25ead672b Add entrypoint script and cacerts to image
deliver / deliver (push) Successful in 2m0s
build / build (pull_request) Successful in 16s
2025-10-07 12:43:48 +02:00
Paul Brinkmeier 4a6e3b2454 Reformat image flake output 2025-10-07 10:28:30 +02:00
paul b739294638 Merge pull request 'CI' (#1) from ci into main
Reviewed-on: #1
2025-10-07 01:17:42 +02:00
Paul Brinkmeier 27f5b8e23c Fix reading image tag
build / build (pull_request) Successful in 1m14s
deliver / deliver (push) Successful in 37s
2025-10-07 01:11:18 +02:00
Paul Brinkmeier 48eb27e218 Add docker image CI workflow
build / build (pull_request) Successful in 1m17s
deliver / deliver (push) Failing after 48s
2025-10-07 01:07:22 +02:00
Paul Brinkmeier 94554ad6e4 Bump opium
build / build (pull_request) Successful in 2m29s
2025-10-07 00:49:51 +02:00
Paul Brinkmeier 1ccde9e5fc Add Gitea Actions config
build / build (pull_request) Successful in 5m40s
2025-10-07 00:26:30 +02:00
Paul Brinkmeier 999c9e8c9e Ignore .gitea in flake.nix 2025-10-07 00:20:34 +02:00
Paul Brinkmeier eff74cecb4 dbmate changes 2025-10-06 10:22:28 +02:00
Paul Brinkmeier e9934276d5 Log service time 2025-10-06 08:52:39 +02:00
Paul Brinkmeier 72ffa08e18 Collect all errors in envy 2025-10-06 08:51:22 +02:00
Paul Brinkmeier 2b85c0fa93 dbmate changes 2025-10-06 08:49:52 +02:00
Paul Brinkmeier 05943c902e Remove get100YearsAgo 2025-09-22 23:54:54 +02:00
Paul Brinkmeier 0bf734730b Move Accept HTML in Yore.Servant 2025-09-22 19:04:51 +02:00
Paul Brinkmeier f2a136d27c Implement HasServer instead of using Raw 2025-09-22 18:04:13 +02:00
Paul Brinkmeier 85bbc8516a Make doIndex a loop 2025-09-22 16:07:42 +02:00
Paul Brinkmeier ac8e8a404a Add dbmate message about database version to schema 2025-09-22 16:06:22 +02:00
Paul Brinkmeier fa60291779 Bump nixpkgs 2025-09-22 11:58:59 +02:00
11 changed files with 275 additions and 104 deletions
+27
View File
@@ -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
+40
View File
@@ -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)
+8 -6
View File
@@ -25,7 +25,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" BASE_DIR=./pgdata scripts/with-db psql "dbname=yore-test port=5433 user=yore-test"
# cabal repl with env vars set # 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. By setting `$BASE_DIR` you can persist the database for later runs.
@@ -41,8 +41,10 @@ By setting `$BASE_DIR` you can persist the database for later runs.
## TODO ## TODO
- CI - [x] CI
- Docker container (in flake) - [x] Docker container (in flake)
- try fourmolu - [x] try fourmolu
- Test leap second handling in the `time` package - [x] Test leap second handling in the `time` package
- use queue to sync logging of indexer and main thread - [ ] Fix container shutdown delay
- [ ] Fix `responseFile` always returning 200
- [ ] use queue to sync logging of indexer and main thread
+60 -67
View File
@@ -17,25 +17,20 @@ import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT)
import Data.Bifunctor (Bifunctor (..)) import Data.Bifunctor (Bifunctor (..))
import Data.Proxy (Proxy (..)) import Data.Proxy (Proxy (..))
import Data.Text (Text) import Data.Text (Text)
import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, toGregorian) import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, nominalDiffTimeToSeconds, toGregorian)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.HTTP.Media ((//), (/:)) import Network.HTTP.Types (Status (..))
import Network.HTTP.Types (Status (..), mkStatus, status200) import Network.Wai (Middleware, Request (..), responseStatus)
import Network.Wai (Application, Request (..), Response, responseFile, responseLBS)
import Servant import Servant
( Accept (..) ( Capture
, Capture
, Get , Get
, Handler , Handler
, MimeRender (..) , MimeRender (..)
, Raw
, ServerError (..) , ServerError (..)
, ServerT , ServerT
, Tagged (..)
, err404 , err404
, err500 , err500
, hoistServer , hoistServer
, runHandler
, serve , serve
, (:<|>) (..) , (:<|>) (..)
, (:>) , (:>)
@@ -62,17 +57,15 @@ import Yore.Download (downloadInto)
import Yore.Error (Error (..)) import Yore.Error (Error (..))
import Yore.Schedule (schedule) import Yore.Schedule (schedule)
import Yore.Scrape (Issue (..), getIssuesByDay) import Yore.Scrape (Issue (..), getIssuesByDay)
import Yore.Servant (GetSendfile, HTML, Sendfile (..))
import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight) import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
import Data.Fixed (Pico)
import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Envy import qualified Envy
import qualified Yore.DB as DB import qualified Yore.DB as DB
import qualified Yore.Log as Log import qualified Yore.Log as Log
import System.IO (hSetBuffering, BufferMode (..), stdout)
newtype ConnectionString = ConnectionString String
deriving (Show)
instance Envy.ReadEnvVar ConnectionString where
readEnvVar = fmap ConnectionString . Envy.readEnvVar
data ConfigT f = Config data ConfigT f = Config
{ yorePort :: f =@@ Int ? 3000 { yorePort :: f =@@ Int ? 3000
@@ -87,10 +80,12 @@ deriving instance Show Config
main :: IO () main :: IO ()
main = do main = do
hSetBuffering stdout NoBuffering
cfg <- cfg <-
Envy.load @ConfigT >>= \case Envy.load @ConfigT >>= \case
Left err -> do Left errs -> do
Log.error $ printf "failed to read config: %s" err forM_ errs $ Log.error . printf "failed to read config: %s"
exitFailure exitFailure
Right c -> Right c ->
pure c pure c
@@ -114,35 +109,40 @@ doIndex :: Config -> DB -> ExceptT Error IO ()
doIndex cfg db = doIndex cfg db =
catchE catchE
( DB.withTransaction db $ \conn -> do ( DB.withTransaction db $ \conn -> do
dayThen <- getTodayWithOffset (-100) 0 forM_ [0, 1, 2] $ \i -> do
indexDay cfg dayThen conn dayThen <- getTodayWithOffset (-100) i
dayThen2 <- getTodayWithOffset (-100) 1 indexDay cfg dayThen conn
indexDay cfg dayThen2 conn
dayThen3 <- getTodayWithOffset (-100) 2
indexDay cfg dayThen3 conn
) )
(Log.error . show) (Log.error . show)
runServer :: Config -> DB -> IO () runServer :: Config -> DB -> IO ()
runServer cfg db = runServer cfg db =
Warp.runSettings settings $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db Warp.runSettings settings $ loggerMiddleware $ serve (Proxy @API) $ hoistServer (Proxy @API) nt $ server cfg db
where where
settings = settings =
foldr foldr
($) ($)
Warp.defaultSettings 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.setBeforeMainLoop $ Log.info $ printf "listening on port %d" cfg.yorePort
, Warp.setOnException onException , Warp.setOnException onException
] ]
logger req status _ = do logger :: Request -> Status -> Pico -> IO ()
Log.info $ logger req status s = do
printf Log.info $ printf "%d %s %ss" (statusCode status) (requestLine req) (formatMetric s)
"%d %s"
(statusCode status) loggerMiddleware :: Middleware
(requestLine req) 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 :: Request -> String
requestLine req = requestLine req =
@@ -151,8 +151,17 @@ runServer cfg db =
(BS8.unpack $ requestMethod req) (BS8.unpack $ requestMethod req)
(BS8.unpack $ rawPathInfo req <> rawQueryString req) (BS8.unpack $ rawPathInfo req <> rawQueryString req)
onException mbReq ex = do formatMetric :: Pico -> String
Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex) 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 :: ExceptT Error IO a -> Handler a
nt action = MkHandler $ do nt action = MkHandler $ do
@@ -164,11 +173,6 @@ nt action = MkHandler $ do
Right x -> Right x ->
pure $ 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 :: Error -> ServerError
toServerError = \case toServerError = \case
ConnectionError msg -> ConnectionError msg ->
@@ -183,14 +187,10 @@ toServerError = \case
encodeUtf8LBS :: String -> LBS.ByteString encodeUtf8LBS :: String -> LBS.ByteString
encodeUtf8LBS = LBS.fromStrict . Encoding.encodeUtf8 . Text.pack encodeUtf8LBS = LBS.fromStrict . Encoding.encodeUtf8 . Text.pack
handlerToRaw :: ExceptT Error IO Response -> Tagged t Application type API =
handlerToRaw handler = Tagged $ \_ respond -> do Get '[HTML] RootModel
r <- runHandler $ nt handler :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel
case r of :<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> GetSendfile
Left e ->
respond $ responseLBS (mkStatus e.errHTTPCode $ BS8.pack e.errReasonPhrase) e.errHeaders e.errBody
Right response ->
respond response
server :: Config -> DB -> ServerT API (ExceptT Error IO) server :: Config -> DB -> ServerT API (ExceptT Error IO)
server cfg db = rootR :<|> todayR :<|> apiTodayR server cfg db = rootR :<|> todayR :<|> apiTodayR
@@ -198,24 +198,25 @@ server cfg db = rootR :<|> todayR :<|> apiTodayR
rootR = todayR 0 rootR = todayR 0
todayR issue = do todayR issue = do
dateThen <- ExceptT get100YearsAgo dateThen <- getTodayWithOffset (-100) 0
count <- DB.withConn db $ DB.getNumberOfIssues dateThen count <- DB.withConn db $ DB.getNumberOfIssues dateThen
dayFile <- DB.withConn db $ DB.getDayFileByIssue dateThen issue dayFile <- DB.withConn db $ DB.getDayFileByIssue dateThen issue
pure $ RootModel dateThen dayFile issue count pure $ RootModel dateThen dayFile issue count
apiTodayR issue = handlerToRaw $ do apiTodayR issue = do
dateThen <- ExceptT get100YearsAgo dateThen <- getTodayWithOffset (-100) 0
dayFile <- DB.withConn db $ DB.getDayFileByIssue dateThen issue dayFile <- DB.withConn db $ DB.getDayFileByIssue dateThen issue
let fullPath = cfg.yoreDownloadDir </> dayFile.relative_path let fullPath = cfg.yoreDownloadDir </> dayFile.relative_path
secondsUntilMidnight <- liftIO getSecondsUntilMidnight secondsUntilMidnight <- liftIO getSecondsUntilMidnight
pure $ pure
responseFile Sendfile
status200 { headers =
[ ("content-type", "application/pdf") [ ("content-type", "application/pdf")
, ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight) , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight)
] ]
fullPath , path =
Nothing fullPath
}
data RootModel = RootModel Day DB.DayFile Int Int data RootModel = RootModel Day DB.DayFile Int Int
@@ -251,14 +252,6 @@ instance MimeRender HTML RootModel where
-- Utils -- Utils
data HTML
instance Accept HTML where
contentType _ = "text" // "html" /: ("charset", "utf-8")
get100YearsAgo :: IO (Either Error Day)
get100YearsAgo = runExceptT $ getTodayWithOffset (-100) 0
getTodayWithOffset :: Integer -> Integer -> ExceptT Error IO Day getTodayWithOffset :: Integer -> Integer -> ExceptT Error IO Day
getTodayWithOffset yearOffset dayOffset = getTodayWithOffset yearOffset dayOffset =
ExceptT $ ExceptT $
@@ -280,7 +273,7 @@ indexDay cfg dayThen conn = do
issues <- liftIO $ getIssuesByDay dayThen issues <- liftIO $ getIssuesByDay dayThen
paths <- forM issues $ \issue -> do paths <- forM issues $ \issue -> do
Log.info $ printf "downloading %s" issue.url Log.info $ printf "downloading %s" issue.url
path <- liftIO $ downloadInto cfg.yoreDownloadDir issue.url path <- downloadInto cfg.yoreDownloadDir issue.url
pure (issue.label, path) pure (issue.label, path)
Log.info "creating DB entries" Log.info "creating DB entries"
dayIndex <- DB.createDayIndex dayThen conn dayIndex <- DB.createDayIndex dayThen conn
+7
View File
@@ -1,3 +1,8 @@
\restrict CAC30PXzQJosjH02Spia1vzj9Ui3LB1Cq2HI8r0A4eu33HP8ngxbbM2SzRfTj0c
-- Dumped from database version 17.6
-- Dumped by pg_dump version 17.6
SET statement_timeout = 0; SET statement_timeout = 0;
SET lock_timeout = 0; SET lock_timeout = 0;
SET idle_in_transaction_session_timeout = 0; SET idle_in_transaction_session_timeout = 0;
@@ -124,6 +129,8 @@ ALTER TABLE ONLY yore.day_file
-- PostgreSQL database dump complete -- PostgreSQL database dump complete
-- --
\unrestrict CAC30PXzQJosjH02Spia1vzj9Ui3LB1Cq2HI8r0A4eu33HP8ngxbbM2SzRfTj0c
-- --
-- Dbmate schema migrations -- Dbmate schema migrations
Generated
+7 -7
View File
@@ -40,11 +40,11 @@
}, },
"nixpkgs": { "nixpkgs": {
"locked": { "locked": {
"lastModified": 1752536923, "lastModified": 1758518877,
"narHash": "sha256-fdgPZR7VFSSRIQKOJLcs3qCJBWM64Uak0gAGtWTYAd8=", "narHash": "sha256-1K1c6vNr/N1PfM77DqKINXQ/oCxA0W1ZJ80sfNzWu0w=",
"owner": "nixos", "owner": "nixos",
"repo": "nixpkgs", "repo": "nixpkgs",
"rev": "c665e4d918eda5d78a175ed8d300809c44932160", "rev": "033cc13ab4c1a60b3527b242755aa625001ff1f9",
"type": "github" "type": "github"
}, },
"original": { "original": {
@@ -64,11 +64,11 @@
] ]
}, },
"locked": { "locked": {
"lastModified": 1756064767, "lastModified": 1759790870,
"narHash": "sha256-SaJK9VYc/oF5aBSMSW+We8TggER4+uTAHvc2ztnLpYo=", "narHash": "sha256-rEsaO38v2wvAThPzgbYPgnv29mu6GxTYLjgci3GYaO4=",
"ref": "main", "ref": "main",
"rev": "af16429d827816cf9bec69026e13f50acc3d2691", "rev": "4db509c1b52ee7b5012abfef5e11e62beab27a16",
"revCount": 65, "revCount": 66,
"type": "git", "type": "git",
"url": "https://git.pbrinkmeier.de/paul/opium" "url": "https://git.pbrinkmeier.de/paul/opium"
}, },
+51 -10
View File
@@ -26,11 +26,18 @@
}; };
# For building the package, we use only the files not ignored by Git as inputs. # 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. # working on them.
src = pkgs.lib.cleanSourceWith { src = pkgs.lib.cleanSourceWith {
src = gitignore.lib.gitignoreSource ./.; src = ./.;
filter = path: type: builtins.elem (builtins.baseNameOf path) [ "flake.nix" "flake.lock" ]; filter = gitignore.lib.gitignoreFilterWith {
basePath = ./.;
extraRules = ''
flake.nix
flake.lock
.gitea
'';
};
}; };
yore = pkgs.lib.pipe yore = pkgs.lib.pipe
@@ -51,16 +58,44 @@
# Return only the bin folder to curb image size # Return only the bin folder to curb image size
compose.justStaticExecutables 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 /tmp/yore-workspace/db
cp -r ${./db}/* /tmp/yore-workspace/db
cd /tmp/yore-workspace/db
dbmate up
# Replace bash and inherit PID 1
cd /
exec yore
'';
};
in { in {
packages = rec { packages = rec {
docker =
pkgs.dockerTools.buildImage {
name = "git.pbrinkmeier.de/paul/yore";
tag = yore.version;
config.Cmd = [ "${yore}/bin/yore" ];
};
default = 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; opium_ = opium.packages.${system}.opium;
}; };
@@ -82,5 +117,11 @@
overrides = addOpium; overrides = addOpium;
}).env; }).env;
}; };
apps = {
crane = {
type = "app";
program = "${pkgs.crane}/bin/crane";
};
};
}); });
} }
+12 -4
View File
@@ -56,13 +56,13 @@ type t ? d = Optional t d
load load
:: forall (m :: ConfigVariant -> Type) :: forall (m :: ConfigVariant -> Type)
. (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value))) . (Generic (m Value), GFromEnv (Rep (m Spec)) (Rep (m Value)))
=> IO (Either String (m Value)) => IO (Either [String] (m Value))
load = do load = do
env <- getEnvironment env <- getEnvironment
pure $ to <$> gFromEnv @(Rep (m Spec)) @(Rep (m Value)) Proxy env pure $ to <$> gFromEnv @(Rep (m Spec)) @(Rep (m Value)) Proxy env
class GFromEnv spec value where 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 instance
(GFromEnv i o) (GFromEnv i o)
@@ -77,7 +77,15 @@ instance
gFromEnv Proxy env = M1 <$> gFromEnv @i @o Proxy env gFromEnv Proxy env = M1 <$> gFromEnv @i @o Proxy env
instance (GFromEnv i1 o1, GFromEnv i2 o2) => GFromEnv (i1 :*: i2) (o1 :*: o2) where 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 instance
(KnownSymbol sym, EnvVarSpec s t) (KnownSymbol sym, EnvVarSpec s t)
@@ -86,7 +94,7 @@ instance
(M1 S meta2 (Rec0 t)) (M1 S meta2 (Rec0 t))
where where
gFromEnv Proxy env = 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 where
varName = selectorNameToEnvVarName $ symbolVal $ Proxy @sym varName = selectorNameToEnvVarName $ symbolVal $ Proxy @sym
+19 -8
View File
@@ -2,7 +2,8 @@
module Yore.Download (downloadInto) where 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.Maybe (fromJust)
import Data.Text (Text) import Data.Text (Text)
import Network.HTTP.Req hiding (queryParam) 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 Data.UUID.V4 as UUID
import qualified Text.URI as URI import qualified Text.URI as URI
import Yore.Error (Error (..))
-- | Download a URL and save it to a directory. -- | Download a URL and save it to a directory.
-- Returns the path of the downloaded file relative to the directory. -- Returns the path of the downloaded file relative to the directory.
downloadInto downloadInto
@@ -21,22 +24,30 @@ downloadInto
-- ^ Directory where to store the file. -- ^ Directory where to store the file.
-> Text -> Text
-- ^ The URL to download. -- ^ The URL to download.
-> IO FilePath -> ExceptT Error IO FilePath
downloadInto downloadDir textUrl = download >>= save downloadInto downloadDir textUrl =
download >>= save
where where
download :: IO LBS.ByteString download :: ExceptT Error IO LBS.ByteString
download = do download = toExceptT (handle @HttpException) $ do
uri <- URI.mkURI textUrl uri <- URI.mkURI textUrl
let (url, opts) = fromJust $ useHttpsURI uri let (url, opts) = fromJust $ useHttpsURI uri
res <- runReq defaultHttpConfig $ req GET url NoReqBody lbsResponse opts res <- runReq defaultHttpConfig $ req GET url NoReqBody lbsResponse opts
guard $ responseStatusCode res == 200
pure $ responseBody res pure $ responseBody res
save :: LBS.ByteString -> IO FilePath save :: LBS.ByteString -> ExceptT Error IO FilePath
save contents = do save contents = toExceptT (handle @IOException) $ do
let suffix = takeExtension $ Text.unpack textUrl let suffix = takeExtension $ Text.unpack textUrl
uuid <- UUID.nextRandom uuid <- UUID.nextRandom
let fullPath = downloadDir </> show uuid <.> suffix let fullPath = downloadDir </> show uuid <.> suffix
createDirectoryIfMissing True downloadDir createDirectoryIfMissing True downloadDir
LBS.writeFile fullPath contents LBS.writeFile fullPath contents
pure $ makeRelative downloadDir fullPath 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
+38
View File
@@ -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")
+6 -2
View File
@@ -1,7 +1,7 @@
cabal-version: 3.4 cabal-version: 3.4
name: yore name: yore
version: 0 version: 0.0.6
author: Paul Brinkmeier author: Paul Brinkmeier
maintainer: hallo@pbrinkmeier.de maintainer: hallo@pbrinkmeier.de
copyright: 2023 Paul Brinkmeier copyright: 2023 Paul Brinkmeier
@@ -41,6 +41,7 @@ library
, Yore.Schedule , Yore.Schedule
, Yore.Scrape , Yore.Scrape
, Yore.Time , Yore.Time
, Yore.Servant
hs-source-dirs: hs-source-dirs:
src src
build-depends: build-depends:
@@ -49,16 +50,20 @@ library
, directory , directory
, filepath , filepath
, html-parse , html-parse
, http-media
, http-types
, lens , lens
, modern-uri , modern-uri
, mtl , mtl
, opium , opium
, req , req
, resource-pool , resource-pool
, servant-server
, text , text
, time , time
, transformers , transformers
, uuid , uuid
, wai
executable yore executable yore
import: shared-options import: shared-options
@@ -77,7 +82,6 @@ executable yore
, bytestring , bytestring
, filepath , filepath
, opium , opium
, http-media
, http-types , http-types
, servant-server , servant-server
, text , text