summaryrefslogtreecommitdiff
path: root/Com/MusicMeetsComics/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Com/MusicMeetsComics/Server.hs')
-rw-r--r--Com/MusicMeetsComics/Server.hs189
1 files changed, 104 insertions, 85 deletions
diff --git a/Com/MusicMeetsComics/Server.hs b/Com/MusicMeetsComics/Server.hs
index 5b12861..5736688 100644
--- a/Com/MusicMeetsComics/Server.hs
+++ b/Com/MusicMeetsComics/Server.hs
@@ -45,24 +45,29 @@ module Com.MusicMeetsComics.Server where
import qualified Clay
import Com.MusicMeetsComics.App
-import qualified Com.MusicMeetsComics.Assets as Assets
+import qualified Com.MusicMeetsComics.Assets as Assets
import qualified Com.MusicMeetsComics.Database as Database
-import qualified Com.MusicMeetsComics.Server.Config as Config
-import qualified Com.MusicMeetsComics.Server.Init as Init
-import qualified Com.MusicMeetsComics.Look as Look
-import qualified Com.MusicMeetsComics.Look.Typography as Typography
+import qualified Com.MusicMeetsComics.Server.Config
+ as Config
+import qualified Com.MusicMeetsComics.Server.Init
+ as Init
+import qualified Com.MusicMeetsComics.Look as Look
+import qualified Com.MusicMeetsComics.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 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 qualified Lucid as L
import Lucid.Base
import Miso
import Miso.String
-import Network.HTTP.Media ((//), (/:))
-import Network.HTTP.Types hiding ( Header )
+import Network.HTTP.Media ( (//)
+ , (/:)
+ )
+import Network.HTTP.Types hiding ( Header )
import Network.Wai
import Network.Wai.Application.Static
import Protolude
@@ -71,11 +76,11 @@ import Servant
main :: IO ()
main = do
- db <- Database.load
- Init.runApp (app db)
+ db <- Database.dummy
+ Init.runApp (app db)
app :: Database.ComicDB -> Config.Config -> Application
-app db _ = serve
+app db cfg = serve
(Proxy @AllRoutes)
( static
:<|> cssHandlers
@@ -84,8 +89,8 @@ app db _ = serve
:<|> pure heroManifest
:<|> Tagged handle404
)
- where
- static = serveDirectoryWith (defaultWebAppSettings "static")
+ where
+ static = serveDirectoryWith $ defaultWebAppSettings $ Config.configClient cfg
-- | HtmlPage for setting HTML doctype and header
@@ -99,25 +104,32 @@ 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")
+ contentType _ = "text" // "css" /: ("charset", "utf-8")
instance MimeRender CSS Text where
- mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict
+ mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict
cssHandlers :: Server CssRoute
-cssHandlers = return . Lazy.toStrict . Clay.render
- $ Typography.main <> Look.main
+cssHandlers =
+ return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main
type AllRoutes
= ("static" :> Raw)
- :<|> CssRoute
- :<|> JsonApi
- :<|> ServerRoutes
- :<|> ("manifest.json" :> Get '[JSON] Manifest)
- :<|> Raw
+ :<|>
+ CssRoute
+ :<|>
+ JsonApi
+ :<|>
+ ServerRoutes
+ :<|>
+ ("manifest.json" :> Get '[JSON] Manifest)
+ :<|>
+ Raw
data Manifest = Manifest
{ name :: Text
@@ -153,58 +165,61 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
toHtmlRaw = L.toHtml
toHtml (HtmlPage x) = do
L.doctype_
- L.html_ [L.lang_ "en"]
- $ do
- L.head_ $ do
- 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.link_
- [ 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.link_
- [ 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.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"]
- L.meta_
- [ L.name_ "viewport"
- , L.content_ "width=device-width, initial-scale=1"
- ]
- cssRef animateRef
- cssRef bulmaRef
- cssRef fontAwesomeRef
- cssRef "/css/main.css" -- TODO: make this a safeLink?
- jsRef "/static/all.js"
- jsRef "/static/usersnap.js"
- L.body_ (L.toHtml x)
+ L.html_ [L.lang_ "en"] $ do
+ L.head_ $ do
+ 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.link_
+ [ 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.link_
+ [ 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.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"]
+ L.meta_
+ [L.name_ "viewport", L.content_ "width=device-width, initial-scale=1"]
+ cssRef animateRef
+ cssRef bulmaRef
+ cssRef fontAwesomeRef
+ cssRef "/css/main.css" -- TODO: make this a safeLink?
+ jsRef "/static/mmc.js"
+ jsRef "/static/usersnap.js"
+ L.body_ (L.toHtml x)
where
jsRef href = L.with
(L.script_ mempty)
@@ -217,8 +232,7 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
[L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
fontAwesomeRef :: MisoString
-fontAwesomeRef =
- "https://use.fontawesome.com/releases/v5.7.2/css/all.css"
+fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css"
animateRef :: MisoString
animateRef =
@@ -246,16 +260,20 @@ homeHandler :: Handler (HtmlPage (View Action))
homeHandler = pure . HtmlPage . home $ initModel homeLink
comicCoverHandler :: ComicId -> Handler (HtmlPage (View Action))
-comicCoverHandler id = pure . HtmlPage . comicCover id . initModel $ comicLink id
+comicCoverHandler id =
+ pure . HtmlPage . comicCover id . initModel $ comicLink id
comicPageHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
-comicPageHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n
+comicPageHandler id n =
+ pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n
comicPageFullHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
-comicPageFullHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n
+comicPageFullHandler id n =
+ pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n
comicVideoHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
-comicVideoHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n
+comicVideoHandler id n =
+ pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n
loginHandler :: Handler (HtmlPage (View Action))
loginHandler = pure . HtmlPage . login $ initModel loginLink
@@ -264,4 +282,5 @@ discoverHandler :: Handler (HtmlPage (View Action))
discoverHandler = pure . HtmlPage . discover $ initModel discoverLink
chooseExperienceHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
-chooseExperienceHandler id n = pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n
+chooseExperienceHandler id n =
+ pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-27 09:26:15 +0000