From 14e3c6a61f7727e994c4e1cf2568a3e606f84648 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sat, 27 Jun 2020 09:20:59 -0700 Subject: hero: implement the basics of user logins There's also a lot of refactoring/renaming in here, so the diff is really messy. The overall problem is that I've only ever added code, I've never gone back and reorganized/rearchitected stuff. So adding even small features is becoming an enormous effort. Anyway, this adds the basics of user auth. Next I need to add the auth checks for every route that needs it, and make sure everything is back to working correctly. --- Hero/App.hs | 311 ++++++++++++++++++++++++++++++------------------------------ 1 file changed, 157 insertions(+), 154 deletions(-) (limited to 'Hero/App.hs') 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"]] -- cgit v1.2.3