summaryrefslogtreecommitdiff
path: root/Hero/App.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Hero/App.hs')
-rw-r--r--Hero/App.hs311
1 files changed, 157 insertions, 154 deletions
diff --git a/Hero/App.hs b/Hero/App.hs
index 418993d..9391eac 100644
--- a/Hero/App.hs
+++ b/Hero/App.hs
@@ -35,37 +35,22 @@ import Hero.Look as Look
import Hero.Look.Typography
import Miso
import qualified Miso (for_)
+import Miso.Extend
import Miso.String
import Network.RemoteData
import Servant.API
( (:<|>) (..),
(:>),
- Capture,
- ToHttpApiData,
- FromHttpApiData,
- URI (..),
- safeLink,
)
+import qualified Servant.API as Api
import Servant.Links (linkURI)
-crossorigin_ :: MisoString -> Attribute action
-crossorigin_ = textProp "crossorigin"
-
-- | The css id for controling music in the comic player.
audioId :: MisoString
audioId = "audioSource"
--- | Like 'onClick' but prevents the default action from triggering. Use this to
--- overide 'a_' links, for example.
-onPreventClick :: Action -> Attribute Action
-onPreventClick action =
- onWithOptions
- Miso.defaultOptions {preventDefault = True}
- "click"
- emptyDecoder
- (\() -> action)
-
--- TODO: make ComicId a hashid https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html
+-- TODO: make ComicId a hashid
+-- https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html
newtype ComicId
= ComicId String
deriving
@@ -77,8 +62,8 @@ newtype ComicId
Generic,
ToMisoString,
IsString,
- ToHttpApiData,
- FromHttpApiData
+ Api.ToHttpApiData,
+ Api.FromHttpApiData
)
instance ToJSON ComicId where
@@ -98,6 +83,8 @@ instance CanSnakeCase Text where
comicSlug :: Comic -> Text
comicSlug Comic {..} = snake comicName <> "-" <> comicIssue
+-- * user
+
data User
= User
{ userEmail :: Text,
@@ -107,10 +94,11 @@ data User
deriving (Show, Eq, Generic, Data, Ord)
instance Semigroup User where
- a <> b = User
- (userEmail a <> userEmail b)
- (userName a <> userName b)
- (userLibrary a <> userLibrary b)
+ a <> b =
+ User
+ (userEmail a <> userEmail b)
+ (userName a <> userName b)
+ (userLibrary a <> userLibrary b)
instance Monoid User where
mempty = User mempty mempty mempty
@@ -121,23 +109,6 @@ instance ToJSON User where
instance FromJSON User where
parseJSON = genericParseJSON Data.Aeson.defaultOptions
-data Comic
- = Comic
- { comicId :: ComicId,
- comicPages :: Integer,
- comicName :: Text,
- -- | Ideally this would be a dynamic number-like type
- comicIssue :: Text,
- comicDescription :: Text
- }
- deriving (Show, Eq, Generic, Data, Ord)
-
-instance ToJSON Comic where
- toJSON = genericToJSON Data.Aeson.defaultOptions
-
-instance FromJSON Comic where
- parseJSON = genericParseJSON Data.Aeson.defaultOptions
-
-- | Class for rendering media objects in different ways.
class IsMediaObject o where
-- | Render a thumbnail for use in a shelf, or otherwise.
@@ -149,74 +120,8 @@ class IsMediaObject o where
-- | Media info view
info :: o -> User -> View Action
-instance IsMediaObject Comic where
- thumbnail c@Comic {..} =
- li_
- []
- [ a_
- [ class_ "comic grow clickable",
- id_ $ "comic-" <> ms comicId,
- onClick $ SetMediaInfo $ Just c
- ]
- [ img_ [src_ $ ms $ Assets.demo <> comicSlug c <> ".png"],
- span_ [] [text $ "Issue #" <> ms comicIssue],
- span_ [] [text $ ms comicName]
- ]
- ]
- feature comic lib =
- div_
- [id_ "featured-comic"]
- [ img_ [id_ "featured-banner", src_ $ ms $ Assets.demo <> "feature-banner.png"],
- div_
- [id_ "featured-content"]
- [ div_
- [class_ "hero-original", css wide]
- [ span_ [css thicc] [text "Herø"],
- span_ [css euro] [text " Original"]
- ],
- div_
- [class_ "comic-logo"]
- [img_ [src_ $ ms $ Assets.demo <> comicSlug comic <> "-logo.png"]],
- div_ [class_ "comic-action-menu"] $ el <$> [Watch comic, Read comic, Save comic lib],
- p_
- [class_ "description"]
- [ text . ms $ comicDescription comic
- ]
- ]
- ]
- info c@Comic {..} lib =
- div_
- [class_ "media-info", css euro]
- [ div_
- [class_ "media-info-meta"]
- [ column [img_ [src_ $ ms $ Assets.demo <> "dmc-widethumb.png"]],
- column
- [ span_ [style_ title] [text $ ms comicName],
- span_ [style_ subtitle] [text $ "Issue #" <> ms comicIssue],
- span_ [] [text "Released: "],
- span_ [] [text $ "Pages: " <> ms (show comicPages :: String)]
- ]
- ],
- div_
- [class_ "media-info-summary"]
- [ p_
- [style_ $ uppercase <> bold <> Look.expanded <> "font-size" =: ".8rem"]
- [text "Summary"],
- p_ [] [text $ ms comicDescription]
- ],
- div_ [class_ "media-info-actions"] $ el <$> [Save c lib, Read c, Watch c]
- -- , row [ text "credits" ]
- ]
- where
- title =
- "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase
- <> "line-height"
- =: "100%"
- <> Look.condensed
- <> bold
- subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed
-
-type ZoomModel = Int
+-- | How much to Zoom the comic image
+type Magnification = Int
-- | All the buttons.
data Button
@@ -224,7 +129,7 @@ data Button
| Read Comic
| Save Comic User
| SaveIcon Comic User
- | ZoomIcon ZoomModel Comic Page
+ | ZoomIcon Magnification Comic Page
| PlayPause MisoString AudioState
| Arrow Action
@@ -336,17 +241,17 @@ findComic id = List.find (\c -> comicId c == id)
-- discover, 'cp' for comic player.
data Model
= Model
- { uri :: URI,
+ { uri :: Api.URI,
appComics :: RemoteData MisoString [Comic],
user :: User,
dMediaInfo :: Maybe Comic,
cpState :: ComicReaderState,
cpAudioState :: AudioState,
- zoomModel :: ZoomModel
+ magnification :: Magnification
}
deriving (Show, Eq)
-initModel :: URI -> Model
+initModel :: Api.URI -> Model
initModel uri_ =
Model
{ uri = uri_,
@@ -355,12 +260,12 @@ initModel uri_ =
user = mempty,
cpState = detectPlayerState uri_,
cpAudioState = Paused,
- zoomModel = 100
+ magnification = 100
}
--- | Hacky way to initialize the 'ComicReaderState' from the URI.
-detectPlayerState :: URI -> ComicReaderState
-detectPlayerState u = case List.splitOn "/" $ uriPath u of
+-- | Hacky way to initialize the 'ComicReaderState' from the Api.URI.
+detectPlayerState :: Api.URI -> ComicReaderState
+detectPlayerState u = case List.splitOn "/" $ Api.uriPath u of
["", "comic", id, pg, "experience"] -> ChooseExperience (ComicId id) (toPage pg)
["", "comic", id, _, "video"] -> Watching $ ComicId id
["", "comic", id, pg, "full"] -> Reading Full (ComicId id) (toPage pg)
@@ -388,10 +293,12 @@ data Action
| -- discover stuff
SetMediaInfo (Maybe Comic)
| ToggleInLibrary Comic
+ | -- login
+ ValidateUserPassword
| -- app stuff
ScrollIntoView MisoString
- | HandleURI URI
- | ChangeURI URI
+ | HandleURI Api.URI
+ | ChangeURI Api.URI
| DumpModel
deriving (Show, Eq)
@@ -427,7 +334,7 @@ routes = Proxy
-- proxy :: Proxy name
-- proxy = Proxy name
-- view :: Model -> View Action
--- link :: URI
+-- link :: Api.URI
-- * home
@@ -440,19 +347,26 @@ homeProxy = Proxy
home :: Model -> View Action
home = login
-homeLink :: URI
-homeLink = linkURI $ safeLink routes homeProxy
+homeLink :: Api.URI
+homeLink = linkURI $ Api.safeLink routes homeProxy
-- * login
+data LoginForm = LoginForm {loginEmail :: String, loginPass :: String}
+ deriving (Eq, Show, Read, Generic)
+
+instance ToJSON LoginForm
+
+instance FromJSON LoginForm
+
type Login =
"login" :> View Action
loginProxy :: Proxy Login
loginProxy = Proxy
-loginLink :: URI
-loginLink = linkURI $ safeLink routes loginProxy
+loginLink :: Api.URI
+loginLink = linkURI $ Api.safeLink routes loginProxy
login :: Model -> View Action
login _ =
@@ -467,8 +381,8 @@ login _ =
hr_ [class_ fadeIn],
form_
[class_ fadeIn]
- [ ctrl [class_ "input", type_ "email", placeholder_ "Email"],
- ctrl [class_ "input", type_ "password", placeholder_ "Password"],
+ [ ctrl [id_ "user", class_ "input", type_ "email", placeholder_ "Email"],
+ ctrl [id_ "pass", class_ "input", type_ "password", placeholder_ "Password"],
div_
[class_ "action", css euro]
[ div_
@@ -477,7 +391,7 @@ login _ =
label_ [Miso.for_ "checkbox"] [text "Remember Me"]
],
div_
- [class_ "button is-black", onClick $ ChangeURI discoverLink]
+ [class_ "button is-black", onClick ValidateUserPassword]
[text "Login"]
]
],
@@ -502,8 +416,8 @@ login _ =
type Discover = "discover" :> View Action
-discoverLink :: URI
-discoverLink = linkURI $ safeLink routes discoverProxy
+discoverLink :: Api.URI
+discoverLink = linkURI $ Api.safeLink routes discoverProxy
discoverProxy :: Proxy Discover
discoverProxy = Proxy
@@ -566,9 +480,102 @@ discoverFooter =
-- * comic
+data Comic
+ = Comic
+ { comicId :: ComicId,
+ comicPages :: Integer,
+ comicName :: Text,
+ -- | Ideally this would be a dynamic number-like type
+ comicIssue :: Text,
+ comicDescription :: Text
+ }
+ deriving (Show, Eq, Generic, Data, Ord)
+
+instance ToJSON Comic where
+ toJSON = genericToJSON Data.Aeson.defaultOptions
+
+instance FromJSON Comic where
+ parseJSON = genericParseJSON Data.Aeson.defaultOptions
+
+instance IsMediaObject Comic where
+ thumbnail c@Comic {..} =
+ li_
+ []
+ [ a_
+ [ class_ "comic grow clickable",
+ id_ $ "comic-" <> ms comicId,
+ onClick $ SetMediaInfo $ Just c
+ ]
+ [ img_ [src_ $ ms $ Assets.demo <> comicSlug c <> ".png"],
+ span_ [] [text $ "Issue #" <> ms comicIssue],
+ span_ [] [text $ ms comicName]
+ ]
+ ]
+ feature comic lib =
+ div_
+ [id_ "featured-comic"]
+ [ img_
+ [ id_ "featured-banner",
+ src_ $ ms $ Assets.demo <> "feature-banner.png"
+ ],
+ div_
+ [id_ "featured-content"]
+ [ div_
+ [class_ "hero-original", css wide]
+ [ span_ [css thicc] [text "Herø"],
+ span_ [css euro] [text " Original"]
+ ],
+ div_
+ [class_ "comic-logo"]
+ [ img_
+ [ src_
+ $ ms
+ $ Assets.demo <> comicSlug comic <> "-logo.png"
+ ]
+ ],
+ div_ [class_ "comic-action-menu"] $
+ el <$> [Watch comic, Read comic, Save comic lib],
+ p_
+ [class_ "description"]
+ [ text . ms $ comicDescription comic
+ ]
+ ]
+ ]
+ info c@Comic {..} lib =
+ div_
+ [class_ "media-info", css euro]
+ [ div_
+ [class_ "media-info-meta"]
+ [ column [img_ [src_ $ ms $ Assets.demo <> "dmc-widethumb.png"]],
+ column
+ [ span_ [style_ title] [text $ ms comicName],
+ span_ [style_ subtitle] [text $ "Issue #" <> ms comicIssue],
+ span_ [] [text "Released: "],
+ span_ [] [text $ "Pages: " <> ms (show comicPages :: String)]
+ ]
+ ],
+ div_
+ [class_ "media-info-summary"]
+ [ p_
+ [style_ $ uppercase <> bold <> Look.expanded <> "font-size" =: ".8rem"]
+ [text "Summary"],
+ p_ [] [text $ ms comicDescription]
+ ],
+ div_ [class_ "media-info-actions"] $ el <$> [Save c lib, Read c, Watch c]
+ -- , row [ text "credits" ]
+ ]
+ where
+ title =
+ "color" =: "red" <> "font-size" =: "1.6rem" <> uppercase
+ <> "line-height"
+ =: "100%"
+ <> Look.condensed
+ <> bold
+ subtitle = "color" =: "#fff" <> "font-size" =: "1.2rem" <> bold <> Look.condensed
+
type ComicCover =
"comic"
- :> Capture "comicId" ComicId
+ :> Api.Capture "comicId" ComicId
:> View Action
comicProxy :: Proxy ComicCover
@@ -577,24 +584,24 @@ comicProxy = Proxy
comicCover :: ComicId -> Model -> View Action
comicCover comicId_ = comicReader comicId_ 1
-comicLink :: ComicId -> URI
-comicLink comicId_ = linkURI $ safeLink routes comicProxy comicId_
+comicLink :: ComicId -> Api.URI
+comicLink comicId_ = linkURI $ Api.safeLink routes comicProxy comicId_
-- * chooseExperience
type ChooseExperience =
"comic"
- :> Capture "id" ComicId
- :> Capture "page" Page
+ :> Api.Capture "id" ComicId
+ :> Api.Capture "page" Page
:> "experience"
:> View Action
chooseExperienceProxy :: Proxy ChooseExperience
chooseExperienceProxy = Proxy
-chooseExperienceLink :: ComicId -> Page -> URI
+chooseExperienceLink :: ComicId -> Page -> Api.URI
chooseExperienceLink id page =
- linkURI $ safeLink routes chooseExperienceProxy id page
+ linkURI $ Api.safeLink routes chooseExperienceProxy id page
chooseExperiencePage :: Comic -> Page -> Model -> View Action
chooseExperiencePage comic page model =
@@ -641,7 +648,6 @@ dark, energetic or dramatic. Feeling indecisive? Let us navigate your journey
with the original curated music for this piece of visual art.
|]
-
-- * comicReader
data ComicReaderView = Spread | Full
@@ -683,21 +689,20 @@ zoomScreen comic page model =
<> padLeft page
<> ".png"
-
-- * comicReaderSpread
type ComicReaderSpread =
"comic"
- :> Capture "id" ComicId
- :> Capture "page" Page
+ :> Api.Capture "id" ComicId
+ :> Api.Capture "page" Page
:> View Action
comicReaderSpreadProxy :: Proxy ComicReaderSpread
comicReaderSpreadProxy = Proxy
-comicReaderSpreadLink :: ComicId -> Page -> URI
+comicReaderSpreadLink :: ComicId -> Page -> Api.URI
comicReaderSpreadLink id page =
- linkURI $ safeLink routes comicReaderSpreadProxy id page
+ linkURI $ Api.safeLink routes comicReaderSpreadProxy id page
comicSpread :: Comic -> Page -> Model -> View Action
comicSpread comic page model =
@@ -741,33 +746,33 @@ closeButton =
type ComicReaderFull =
"comic"
- :> Capture "id" ComicId
- :> Capture "page" Page
+ :> Api.Capture "id" ComicId
+ :> Api.Capture "page" Page
:> "full"
:> View Action
comicReaderFullProxy :: Proxy ComicReaderFull
comicReaderFullProxy = Proxy
-comicReaderFullLink :: ComicId -> Page -> URI
+comicReaderFullLink :: ComicId -> Page -> Api.URI
comicReaderFullLink id page =
- linkURI $ safeLink routes comicReaderFullProxy id page
+ linkURI $ Api.safeLink routes comicReaderFullProxy id page
-- * comicVideo
type ComicVideo =
"comic"
- :> Capture "id" ComicId
- :> Capture "page" Page
+ :> Api.Capture "id" ComicId
+ :> Api.Capture "page" Page
:> "video"
:> View Action
comicVideoProxy :: Proxy ComicVideo
comicVideoProxy = Proxy
-comicVideoLink :: ComicId -> Page -> URI
+comicVideoLink :: ComicId -> Page -> Api.URI
comicVideoLink id page =
- linkURI $ safeLink routes comicVideoProxy id page
+ linkURI $ Api.safeLink routes comicVideoProxy id page
frameborder_ :: MisoString -> Attribute action
frameborder_ = textProp "frameborder"
@@ -794,7 +799,6 @@ comicVideo _ _ _ =
]
]
-
-- * general page components & utils
-- | If 'View' had a 'Monoid' instance, then '(text "")' could just be 'mempty'
@@ -886,7 +890,7 @@ comicControls comic page model =
div_
[class_ "comic-controls-share"]
[ el $ SaveIcon comic $ user model,
- el $ ZoomIcon (zoomModel model) comic page,
+ el $ ZoomIcon (magnification model) comic page,
button_
[class_ "button icon is-large", onClick ToggleFullscreen]
[i_ [class_ "fa fa-expand"] []]
@@ -928,6 +932,5 @@ column :: [View Action] -> View Action
column = div_ [css $ Clay.display Clay.flex <> Clay.flexDirection Clay.column]
-- | Links
-
the404 :: Model -> View Action
the404 _ = template "404" [p_ [] [text "Not found"]]
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 10:39:28 +0000