summaryrefslogtreecommitdiff
path: root/Hero/Host.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Hero/Host.hs')
-rw-r--r--Hero/Host.hs157
1 files changed, 79 insertions, 78 deletions
diff --git a/Hero/Host.hs b/Hero/Host.hs
index d547fa5..9d10f02 100644
--- a/Hero/Host.hs
+++ b/Hero/Host.hs
@@ -9,7 +9,6 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
-
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Hero web app
@@ -83,57 +82,59 @@ main = bracket startup shutdown run
where
run (cfg, app, _) = Warp.run (heroPort cfg) app
prn = IO.hPutStrLn IO.stderr
- startup = Envy.decodeEnv >>= \case
- Left e -> Exit.die e
- Right cfg ->
- do
- keep <- Keep.open (heroKeep cfg)
- skey <- upsertKey (heroSkey cfg)
- say "hero"
- prn <| "port: " ++ show (heroPort cfg)
- prn <| "keep: " ++ heroKeep cfg
- prn <| "node: " ++ heroNode cfg
- prn <| "skey: " ++ heroSkey cfg
- let jwts = Auth.defaultJWTSettings skey
- cs =
- Auth.defaultCookieSettings
- { -- uncomment this for insecure dev
- Auth.cookieIsSecure = Auth.NotSecure,
- Auth.cookieXsrfSetting = Nothing
- }
- ctx = cs :. jwts :. EmptyContext
- proxy = Proxy @(AllRoutes '[Auth.JWT, Auth.Cookie])
- static = serveDirectoryWith <| defaultWebAppSettings <| heroNode cfg
- server =
- -- assets, auth, and the homepage is public
- static
- :<|> cssHandlers
- :<|> pure heroManifest
- :<|> pubHostHandlers
- :<|> authHandler cs jwts
- -- app and api are private
- :<|> wrapAuth (jsonHandlers keep)
- :<|> wrapAuth appHostHandlers
- -- fall through to 404
- :<|> Tagged handle404
- return
- ( cfg,
- serveWithContext
- proxy
- ctx
- server,
- keep
- )
+ startup =
+ Envy.decodeEnv >>= \case
+ Left e -> Exit.die e
+ Right cfg ->
+ do
+ keep <- Keep.open (heroKeep cfg)
+ skey <- upsertKey (heroSkey cfg)
+ say "hero"
+ prn <| "port: " ++ show (heroPort cfg)
+ prn <| "keep: " ++ heroKeep cfg
+ prn <| "node: " ++ heroNode cfg
+ prn <| "skey: " ++ heroSkey cfg
+ let jwts = Auth.defaultJWTSettings skey
+ cs =
+ Auth.defaultCookieSettings
+ { -- uncomment this for insecure dev
+ Auth.cookieIsSecure = Auth.NotSecure,
+ Auth.cookieXsrfSetting = Nothing
+ }
+ ctx = cs :. jwts :. EmptyContext
+ proxy = Proxy @(AllRoutes '[Auth.JWT, Auth.Cookie])
+ static = serveDirectoryWith <| defaultWebAppSettings <| heroNode cfg
+ server =
+ -- assets, auth, and the homepage is public
+ static
+ :<|> cssHandlers
+ :<|> pure heroManifest
+ :<|> pubHostHandlers
+ :<|> authHandler cs jwts
+ -- app and api are private
+ :<|> wrapAuth (jsonHandlers keep)
+ :<|> wrapAuth appHostHandlers
+ -- fall through to 404
+ :<|> Tagged handle404
+ return
+ ( cfg,
+ serveWithContext
+ proxy
+ ctx
+ server,
+ keep
+ )
shutdown :: App -> IO ()
shutdown (_, _, keep) = do
Keep.close keep
return ()
upsertKey :: FilePath -> IO Crypto.JWK
-upsertKey fp = Directory.doesFileExist fp >>= \exists ->
- if exists
- then Auth.readKey fp
- else Auth.writeKey fp >> Auth.readKey fp
+upsertKey fp =
+ Directory.doesFileExist fp >>= \exists ->
+ if exists
+ then Auth.readKey fp
+ else Auth.writeKey fp >> Auth.readKey fp
-- This part is a little confusing. I have:
--
@@ -150,13 +151,12 @@ upsertKey fp = Directory.doesFileExist fp >>= \exists ->
-- | This can be generalized I think, put in Biz.App, or something
type App = (Config, Application, AcidState Keep.HeroKeep)
-data Config
- = Config
- { heroPort :: Warp.Port,
- heroNode :: FilePath,
- heroKeep :: FilePath,
- heroSkey :: FilePath
- }
+data Config = Config
+ { heroPort :: Warp.Port,
+ heroNode :: FilePath,
+ heroKeep :: FilePath,
+ heroSkey :: FilePath
+ }
deriving (Generic, Show)
instance Envy.DefConfig Config where
@@ -206,12 +206,13 @@ type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
cssHandlers :: Server CssRoute
cssHandlers =
- return . Lazy.toStrict . Clay.render <| Typography.main <> Look.main
+ return <. Lazy.toStrict <. Clay.render <| Typography.main <> Look.main
type AuthRoute =
"auth"
:> ReqBody '[JSON] LoginForm
- :> Post '[JSON]
+ :> Post
+ '[JSON]
( Headers
'[ Header "Set-Cookie" Auth.SetCookie,
Header "Set-Cookie" Auth.SetCookie
@@ -291,37 +292,37 @@ instance L.ToHtml a => L.ToHtml (Templated a) where
L.link_
[ L.rel_ "apple-touch-icon",
L.sizes_ "180x180",
- L.href_ <|
- Pack.cdnEdge
- <> "/old-assets/images/favicons/apple-touch-icon.png"
+ L.href_
+ <| Pack.cdnEdge
+ <> "/old-assets/images/favicons/apple-touch-icon.png"
]
L.link_
[ L.rel_ "icon",
L.type_ "image/png",
L.sizes_ "32x32",
- L.href_ <|
- Pack.cdnEdge
- <> "/old-assets/images/favicons/favicon-32x32.png"
+ L.href_
+ <| Pack.cdnEdge
+ <> "/old-assets/images/favicons/favicon-32x32.png"
]
L.link_
[ L.rel_ "icon",
L.type_ "image/png",
L.sizes_ "16x16",
- L.href_ <|
- Pack.cdnEdge
- <> "/old-assets/images/favicons/favicon-16x16.png"
+ L.href_
+ <| Pack.cdnEdge
+ <> "/old-assets/images/favicons/favicon-16x16.png"
]
L.link_
[ L.rel_ "manifest",
- L.href_ <|
- Pack.cdnEdge
- <> "/old-assets/images/favicons/manifest.json"
+ L.href_
+ <| Pack.cdnEdge
+ <> "/old-assets/images/favicons/manifest.json"
]
L.link_
[ L.rel_ "mask-icon",
- L.href_ <|
- Pack.cdnEdge
- <> "/old-assets/images/favicons/safari-pinned-tab.svg"
+ L.href_
+ <| Pack.cdnEdge
+ <> "/old-assets/images/favicons/safari-pinned-tab.svg"
]
L.meta_ [L.charset_ "utf-8"]
L.meta_ [L.name_ "theme-color", L.content_ "#000"]
@@ -373,30 +374,30 @@ bulmaRef =
"https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css"
homeHandler :: Handler (Templated (View Move))
-homeHandler = pure . Templated . home <| initForm homeLink
+homeHandler = pure <. Templated <. home <| initForm homeLink
comicCoverHandler :: ComicId -> Handler (Templated (View Move))
comicCoverHandler id =
- pure . Templated . comicCover id . initForm <| comicLink id
+ pure <. Templated <. comicCover id <. initForm <| comicLink id
comicPageHandler :: ComicId -> PageNumber -> Handler (Templated (View Move))
comicPageHandler id n =
- pure . Templated . comicReader id n . initForm <| comicReaderSpreadLink id n
+ pure <. Templated <. comicReader id n <. initForm <| comicReaderSpreadLink id n
comicPageFullHandler :: ComicId -> PageNumber -> Handler (Templated (View Move))
comicPageFullHandler id n =
- pure . Templated . comicReader id n . initForm <| comicReaderFullLink id n
+ pure <. Templated <. comicReader id n <. initForm <| comicReaderFullLink id n
comicVideoHandler :: ComicId -> PageNumber -> Handler (Templated (View Move))
comicVideoHandler id n =
- pure . Templated . comicReader id n . initForm <| comicVideoLink id n
+ pure <. Templated <. comicReader id n <. initForm <| comicVideoLink id n
discoverHandler :: Handler (Templated (View Move))
-discoverHandler = pure . Templated . discover <| initForm discoverLink
+discoverHandler = pure <. Templated <. discover <| initForm discoverLink
chooseExperienceHandler :: ComicId -> PageNumber -> Handler (Templated (View Move))
chooseExperienceHandler id n =
- pure . Templated . comicReader id n . initForm <| chooseExperienceLink id n
+ pure <. Templated <. comicReader id n <. initForm <| chooseExperienceLink id n
loginHandler :: Handler (Templated (View Move))
-loginHandler = pure . Templated . login <| initForm loginLink
+loginHandler = pure <. Templated <. login <| initForm loginLink
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 21:56:06 +0000