summaryrefslogtreecommitdiff
path: root/Hero/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Hero/Server.hs')
-rw-r--r--Hero/Server.hs277
1 files changed, 141 insertions, 136 deletions
diff --git a/Hero/Server.hs b/Hero/Server.hs
index 730aada..450bd0d 100644
--- a/Hero/Server.hs
+++ b/Hero/Server.hs
@@ -1,15 +1,16 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
-- | Hero web app
--
-- : exe mmc
@@ -40,56 +41,59 @@
module Hero.Server where
import qualified Clay
-import Hero.App
-import qualified Hero.Assets as Assets
+import Data.Aeson
+import Data.Proxy
+import Data.Text (Text)
+import qualified Data.Text.Lazy as Lazy
+import qualified Data.Text.Lazy.Encoding as Lazy
+import GHC.Generics
+import Hero.App
+import qualified Hero.Assets as Assets
import qualified Hero.Database as Database
-import qualified Hero.Look as Look
-import qualified Hero.Look.Typography
- as Typography
-import Data.Aeson
-import Data.Proxy
-import Data.Text ( Text )
-import qualified Data.Text.Lazy as Lazy
-import qualified Data.Text.Lazy.Encoding as Lazy
-import GHC.Generics
-import qualified Lucid as L
-import Lucid.Base
-import Miso
-import Miso.String
-import Network.HTTP.Media ( (//)
- , (/:)
- )
-import Network.HTTP.Types hiding ( Header )
-import Network.Wai
-import Network.Wai.Application.Static
-import qualified Network.Wai.Handler.Warp as Warp
-import Protolude
-import Servant
-import qualified System.Envy as Envy
-import qualified System.Exit as Exit
-import qualified System.IO as IO
-
+import qualified Hero.Look as Look
+import qualified Hero.Look.Typography as Typography
+import qualified Lucid as L
+import Lucid.Base
+import Miso
+import Miso.String
+import Network.HTTP.Media
+ ( (//),
+ (/:),
+ )
+import Network.HTTP.Types hiding (Header)
+import Network.Wai
+import Network.Wai.Application.Static
+import qualified Network.Wai.Handler.Warp as Warp
+import Protolude
+import Servant
+import qualified System.Envy as Envy
+import qualified System.Exit as Exit
+import qualified System.IO as IO
main :: IO ()
main = bracket startup shutdown $ uncurry Warp.run
- where
- say = IO.hPutStrLn IO.stderr
- startup = Envy.decodeEnv >>= \case
- Left e -> Exit.die e
- Right c -> do
- db <- Database.dummy
- say $ "hero"
- say $ "port: " ++ (show $ heroPort c)
- say $ "client: " ++ heroClient c
- let waiapp = app db c
- return (heroPort c, waiapp)
- shutdown :: a -> IO a
- shutdown = pure . identity
-
-data Config = Config
- { heroPort :: Warp.Port -- ^ HERO_PORT
- , heroClient :: FilePath -- ^ HERO_CLIENT
- } deriving (Generic, Show)
+ where
+ say = IO.hPutStrLn IO.stderr
+ startup = Envy.decodeEnv >>= \case
+ Left e -> Exit.die e
+ Right c -> do
+ db <- Database.dummy
+ say $ "hero"
+ say $ "port: " ++ (show $ heroPort c)
+ say $ "client: " ++ heroClient c
+ let waiapp = app db c
+ return (heroPort c, waiapp)
+ shutdown :: a -> IO a
+ shutdown = pure . identity
+
+data Config
+ = Config
+ { -- | HERO_PORT
+ heroPort :: Warp.Port,
+ -- | HERO_CLIENT
+ heroClient :: FilePath
+ }
+ deriving (Generic, Show)
instance Envy.DefConfig Config where
defConfig = Config 3000 "_bild/Hero.Client/static"
@@ -97,17 +101,18 @@ instance Envy.DefConfig Config where
instance Envy.FromEnv Config
app :: Database.ComicDB -> Config -> Application
-app db cfg = serve
- (Proxy @AllRoutes)
- ( static
- :<|> cssHandlers
- :<|> jsonHandlers db
- :<|> serverHandlers
- :<|> pure heroManifest
- :<|> Tagged handle404
- )
- where static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg
-
+app db cfg =
+ serve
+ (Proxy @AllRoutes)
+ ( static
+ :<|> cssHandlers
+ :<|> jsonHandlers db
+ :<|> serverHandlers
+ :<|> pure heroManifest
+ :<|> Tagged handle404
+ )
+ where
+ static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg
-- | HtmlPage for setting HTML doctype and header
newtype HtmlPage a = HtmlPage a
@@ -120,9 +125,10 @@ type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic]
type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
-newtype CSS = CSS
- { unCSS :: Text
- }
+newtype CSS
+ = CSS
+ { unCSS :: Text
+ }
instance Accept CSS where
contentType _ = "text" // "css" /: ("charset", "utf-8")
@@ -134,38 +140,37 @@ cssHandlers :: Server CssRoute
cssHandlers =
return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main
-type AllRoutes
- = ("static" :> Raw)
- :<|>
- CssRoute
- :<|>
- JsonApi
- :<|>
- ServerRoutes
- :<|>
- ("manifest.json" :> Get '[JSON] Manifest)
- :<|>
- Raw
-
-data Manifest = Manifest
- { name :: Text
- , short_name :: Text
- , start_url :: Text
- , display :: Text
- , theme_color :: Text
- , description :: Text
- } deriving (Show, Eq, Generic)
+type AllRoutes =
+ ("static" :> Raw)
+ :<|> CssRoute
+ :<|> JsonApi
+ :<|> ServerRoutes
+ :<|> ("manifest.json" :> Get '[JSON] Manifest)
+ :<|> Raw
+
+data Manifest
+ = Manifest
+ { name :: Text,
+ short_name :: Text,
+ start_url :: Text,
+ display :: Text,
+ theme_color :: Text,
+ description :: Text
+ }
+ deriving (Show, Eq, Generic)
instance ToJSON Manifest
heroManifest :: Manifest
-heroManifest = Manifest { name = "Hero"
- , short_name = "Hero"
- , start_url = "."
- , display = "standalone"
- , theme_color = "#0a0a0a"
- , description = "Comics for all"
- }
+heroManifest =
+ Manifest
+ { name = "Hero",
+ short_name = "Hero",
+ start_url = ".",
+ display = "standalone",
+ theme_color = "#0a0a0a",
+ description = "Comics for all"
+ }
handle404 :: Application
handle404 _ respond =
@@ -186,44 +191,42 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
L.title_ "Hero [alpha]"
L.link_ [L.rel_ "manifest", L.href_ "/manifest.json"]
L.link_ [L.rel_ "icon", L.type_ ""]
-
-- icons
L.link_
- [ L.rel_ "apple-touch-icon"
- , L.sizes_ "180x180"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/apple-touch-icon.png"
+ [ L.rel_ "apple-touch-icon",
+ L.sizes_ "180x180",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/apple-touch-icon.png"
]
L.link_
- [ L.rel_ "icon"
- , L.type_ "image/png"
- , L.sizes_ "32x32"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/favicon-32x32.png"
+ [ L.rel_ "icon",
+ L.type_ "image/png",
+ L.sizes_ "32x32",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/favicon-32x32.png"
]
L.link_
- [ L.rel_ "icon"
- , L.type_ "image/png"
- , L.sizes_ "16x16"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/favicon-16x16.png"
+ [ L.rel_ "icon",
+ L.type_ "image/png",
+ L.sizes_ "16x16",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/favicon-16x16.png"
]
L.link_
- [ L.rel_ "manifest"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/manifest.json"
+ [ L.rel_ "manifest",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/manifest.json"
]
L.link_
- [ L.rel_ "mask-icon"
- , L.href_
- $ Assets.cdnEdge
- <> "/old-assets/images/favicons/safari-pinned-tab.svg"
+ [ L.rel_ "mask-icon",
+ L.href_ $
+ Assets.cdnEdge
+ <> "/old-assets/images/favicons/safari-pinned-tab.svg"
]
-
L.meta_ [L.charset_ "utf-8"]
L.meta_ [L.name_ "theme-color", L.content_ "#000"]
L.meta_ [L.httpEquiv_ "X-UA-Compatible", L.content_ "IE=edge"]
@@ -236,16 +239,18 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
jsRef "/static/mmc.js"
jsRef "/static/usersnap.js"
L.body_ (L.toHtml x)
- where
- jsRef href = L.with
- (L.script_ mempty)
- [ makeAttribute "src" href
- , makeAttribute "async" mempty
- , makeAttribute "defer" mempty
- ]
- cssRef href = L.with
- (L.link_ mempty)
- [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
+ where
+ jsRef href =
+ L.with
+ (L.script_ mempty)
+ [ makeAttribute "src" href,
+ makeAttribute "async" mempty,
+ makeAttribute "defer" mempty
+ ]
+ cssRef href =
+ L.with
+ (L.link_ mempty)
+ [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
fontAwesomeRef :: MisoString
fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 16:34:54 +0000