Reorganize a bunch of code

Nothing should be functioning differntly, just made it easier to work on.

1 files changed, 41 insertions, 70 deletions

diff --git a/Hero/Server.hs b/Hero/Server.hs
index 351e839..97ce7a2 100644
--- a/Hero/Server.hs
+++ b/Hero/Server.hs
@@ -40,15 +40,13 @@
 -- : dep warp
 module Hero.Server where
 
+import Alpha
+import Biz.App (CSS(..), Manifest(..))
 import qualified Clay
 import Data.Acid (AcidState)
 import qualified Data.Acid.Abstract as Acid
-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.Keep as Keep
@@ -58,15 +56,10 @@ 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
@@ -76,15 +69,15 @@ main :: IO ()
 main = bracket startup shutdown run
   where
     run (cfg, app, _) = Warp.run (heroPort cfg) app
-    say = IO.hPutStrLn IO.stderr
+    prn = IO.hPutStrLn IO.stderr
     startup = Envy.decodeEnv >>= \case
       Left e -> Exit.die e
       Right cfg -> do
         keep <- Keep.open (heroKeep cfg)
         say "hero"
-        say $ "port: " ++ show (heroPort cfg)
-        say $ "beam: " ++ heroBeam cfg
-        say $ "keep: " ++ heroKeep cfg
+        prn $ "port: " ++ show (heroPort cfg)
+        prn $ "beam: " ++ heroBeam cfg
+        prn $ "keep: " ++ heroKeep cfg
         let waiapp = mkApp keep cfg
         return (cfg, waiapp, keep)
     shutdown :: App -> IO ()
@@ -134,28 +127,13 @@ mkApp keep cfg =
   where
     static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg
 
--- | HtmlPage for setting HTML doctype and header
-newtype HtmlPage a = HtmlPage a
-  deriving (Show, Eq)
-
 -- | Convert client side routes into server-side web handlers
-type ServerRoutes = ToServerRoutes ClientRoutes HtmlPage Action
+type ServerRoutes = ToServerRoutes ClientRoutes Templated Action
 
 type JsonApi = "api" :> "comic" :> Get '[JSON] [Comic]
 
 type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
 
-newtype CSS
-  = CSS
-      { unCSS :: Text
-      }
-
-instance Accept CSS where
-  contentType _ = "text" // "css" /: ("charset", "utf-8")
-
-instance MimeRender CSS Text where
-  mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict
-
 cssHandlers :: Server CssRoute
 cssHandlers =
   return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main
@@ -168,19 +146,6 @@ type AllRoutes =
     :<|> ("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
@@ -192,19 +157,13 @@ heroManifest =
       description = "Comics for all"
     }
 
-handle404 :: Application
-handle404 _ respond =
-  respond
-    $ responseLBS status404 [("Content-Type", "text/html")]
-    $ renderBS
-    $ toHtml
-    $ HtmlPage
-    $ the404
-    $ initModel homeLink
+-- | Type for setting wrapping a view in HTML doctype, header, etc
+newtype Templated a = Templated a
+  deriving (Show, Eq)
 
-instance L.ToHtml a => L.ToHtml (HtmlPage a) where
+instance L.ToHtml a => L.ToHtml (Templated a) where
   toHtmlRaw = L.toHtml
-  toHtml (HtmlPage x) = do
+  toHtml (Templated x) = do
     L.doctype_
     L.html_ [L.lang_ "en"] $ do
       L.head_ $ do
@@ -272,6 +231,17 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
           (L.link_ mempty)
           [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href]
 
+
+handle404 :: Application
+handle404 _ respond =
+  respond
+    $ responseLBS status404 [("Content-Type", "text/html")]
+    $ renderBS
+    $ toHtml
+    $ Templated
+    $ the404
+    $ initModel homeLink
+
 fontAwesomeRef :: MisoString
 fontAwesomeRef = "https://use.fontawesome.com/releases/v5.7.2/css/all.css"
 
@@ -297,31 +267,32 @@ serverHandlers =
 jsonHandlers :: AcidState Keep.HeroKeep -> Server JsonApi
 jsonHandlers keep = Acid.query' keep $ Keep.GetComics 10
 
-homeHandler :: Handler (HtmlPage (View Action))
-homeHandler = pure . HtmlPage . home $ initModel homeLink
+homeHandler :: Handler (Templated (View Action))
+homeHandler = pure . Templated . home $ initModel homeLink
 
-comicCoverHandler :: ComicId -> Handler (HtmlPage (View Action))
+comicCoverHandler :: ComicId -> Handler (Templated (View Action))
 comicCoverHandler id =
-  pure . HtmlPage . comicCover id . initModel $ comicLink id
+  pure . Templated . comicCover id . initModel $ comicLink id
 
-comicPageHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+comicPageHandler :: ComicId -> Page -> Handler (Templated (View Action))
 comicPageHandler id n =
-  pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerSpreadLink id n
+  pure . Templated . comicReader id n . initModel $ comicReaderSpreadLink id n
 
-comicPageFullHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+comicPageFullHandler :: ComicId -> Page -> Handler (Templated (View Action))
 comicPageFullHandler id n =
-  pure . HtmlPage . comicPlayer id n . initModel $ comicPlayerFullLink id n
+  pure . Templated . comicReader id n . initModel $ comicReaderFullLink id n
 
-comicVideoHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+comicVideoHandler :: ComicId -> Page -> Handler (Templated (View Action))
 comicVideoHandler id n =
-  pure . HtmlPage . comicPlayer id n . initModel $ comicVideoLink id n
+  pure . Templated . comicReader id n . initModel $ comicVideoLink id n
 
-loginHandler :: Handler (HtmlPage (View Action))
-loginHandler = pure . HtmlPage . login $ initModel loginLink
+discoverHandler :: Handler (Templated (View Action))
+discoverHandler = pure . Templated . discover $ initModel discoverLink
 
-discoverHandler :: Handler (HtmlPage (View Action))
-discoverHandler = pure . HtmlPage . discover $ initModel discoverLink
-
-chooseExperienceHandler :: ComicId -> Page -> Handler (HtmlPage (View Action))
+chooseExperienceHandler :: ComicId -> Page -> Handler (Templated (View Action))
 chooseExperienceHandler id n =
-  pure . HtmlPage . comicPlayer id n . initModel $ chooseExperienceLink id n
+  pure . Templated . comicReader id n . initModel $ chooseExperienceLink id n
+
+loginHandler :: Handler (Templated (View Action))
+loginHandler = pure . Templated . login $ initModel loginLink
+