diff options
| -rw-r--r-- | .envrc | 2 | ||||
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Hero/App.hs | 311 | ||||
| -rw-r--r-- | Hero/Client.hs | 114 | ||||
| -rw-r--r-- | Hero/Server.hs | 156 | ||||
| -rw-r--r-- | Hero/Service.nix | 5 | ||||
| -rw-r--r-- | Miso/Extend.hs | 26 | ||||
| -rwxr-xr-x | bild | 2 | ||||
| -rw-r--r-- | nix/haskell-deps.nix | 3 | ||||
| -rw-r--r-- | nix/haskell-overlay.nix | 13 | ||||
| -rw-r--r-- | nix/sources.json | 12 |
11 files changed, 421 insertions, 224 deletions
@@ -1,10 +1,10 @@ PATH_add $PWD -export NIX_PATH=$PWD/nix export BIZ_ROOT=$PWD export HERO_PORT=3000 export HERO_BEAM=$BIZ_ROOT/_bild/Hero.Client/static export HERO_KEEP=$BIZ_ROOT/_keep +export HERO_SKEY=$BIZ_ROOT/_skey export GUILE_LOAD_PATH=$PWD export EDITOR=vim @@ -8,5 +8,6 @@ tags .tex .pdf _keep +_skey *~ dist* 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"]] diff --git a/Hero/Client.hs b/Hero/Client.hs index 2b222bd..06a7eab 100644 --- a/Hero/Client.hs +++ b/Hero/Client.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -18,9 +19,12 @@ -- : dep ghcjs-base module Hero.Client where +import Alpha +import Biz.Auth as Auth import Data.Aeson (eitherDecodeStrict) import qualified Data.Set as Set import qualified GHC.Show as Legacy +import GHCJS.Types (JSVal) import Hero.App ( Action (..), AudioState (..), @@ -34,18 +38,13 @@ import Hero.App comicReaderFullLink, comicReaderSpreadLink, comicVideoLink, + discoverLink, handlers, initModel, routes, the404, ) -import JavaScript.Web.XMLHttpRequest - ( Method (GET), - Request (..), - RequestData (NoData), - contents, - xhrByteString, - ) +import JavaScript.Web.XMLHttpRequest as Ajax import Miso import Miso.Effect.DOM (scrollIntoView) import qualified Miso.FFI.Audio as Audio @@ -66,7 +65,7 @@ main = miso $ \currentURI -> App {model = initModel currentURI, ..} keyboardSub keynav ] events = defaultEvents - initialAction = FetchComics + initialAction = NoOp mountPoint = Nothing (∈) :: Ord a => a -> Set a -> Bool @@ -75,8 +74,8 @@ main = miso $ \currentURI -> App {model = initModel currentURI, ..} -- | Keyboard navigation - maps keys to actions. keynav :: Set Int -> Action keynav ks - | 37 ∈ ks = PrevPage -- left arrow - | 39 ∈ ks = NextPage -- right arrow + | 37 ∈ ks = PrevPage -- ← + | 39 ∈ ks = NextPage -- → | 191 ∈ ks = DumpModel -- ? | 32 ∈ ks = ToggleAudio audioId -- SPC | otherwise = NoOp @@ -89,13 +88,16 @@ see model = -- | Console-logging foreign import javascript unsafe "console.log($1);" - say :: MisoString -> IO () + jslog :: MisoString -> IO () + +foreign import javascript unsafe "$1.value" + getValue :: JSVal -> IO MisoString -- | Updates model, optionally introduces side effects move :: Action -> Model -> Effect Action Model move NoOp model = noEff model move DumpModel model = model <# do - say $ ms $ Legacy.show model + jslog $ ms $ Legacy.show model pure NoOp move (SelectExperience comic) model = model {cpState = ChooseExperience (comicId comic) 1} <# do pure $ ChangeURI $ chooseExperienceLink (comicId comic) 1 @@ -133,7 +135,7 @@ move (ToggleZoom c pg) m = m {cpState = newState} <# pure act x -> (x, NoOp) move (ToggleInLibrary c) model = model {user = newUser} <# pure NoOp where - newUser = (user model) { userLibrary = newLib } + newUser = (user model) {userLibrary = newLib} newLib | c `elem` (userLibrary $ user model) = Protolude.filter (/= c) $ userLibrary $ user model @@ -171,27 +173,79 @@ move (SetMediaInfo x) model = model {dMediaInfo = x} Nothing -> pure NoOp move (ScrollIntoView id) model = model <# do - say $ ms $ Legacy.show id + jslog $ ms $ Legacy.show id scrollIntoView id pure NoOp +move ValidateUserPassword model = + batchEff + model + [doLogin, (SetComics </ fetchComics)] + where + doLogin = do + user <- getValue =<< Document.getElementById "user" + pass <- getValue =<< Document.getElementById "pass" + jslog "sending login" + sendLogin (ms user) (ms pass) >>= \case + Network.Success user -> do + jslog "successful login" + pure $ ChangeURI discoverLink + -- TODO: handle these error cases + Network.Loading -> pure NoOp + Network.Failure _ -> pure NoOp + Network.NotAsked -> pure NoOp fetchComics :: IO (Network.RemoteData MisoString [Comic]) -fetchComics = do - mjson <- contents <$> xhrByteString req - case mjson of - Nothing -> - pure $ Network.Failure "Could not fetch comics from server." - Just json -> - pure $ Network.fromEither - $ either (Left . ms) pure - $ eitherDecodeStrict json +fetchComics = Ajax.xhrByteString req /> Ajax.contents >>= \case + Nothing -> + pure $ Network.Failure "Could not fetch comics from server." + Just json -> + pure $ Network.fromEither + $ either (Left . ms) pure + $ eitherDecodeStrict json + where + req = + Ajax.Request + { Ajax.reqMethod = Ajax.GET, + Ajax.reqURI = "/api/comic", -- FIXME: can we replace this hardcoding? + Ajax.reqLogin = Nothing, + Ajax.reqHeaders = [], + Ajax.reqWithCredentials = False, + Ajax.reqData = Ajax.NoData + } + +sendLogin :: + Auth.Username -> + Auth.Password -> + IO + ( Network.RemoteData MisoString + User + ) +sendLogin u p = Ajax.xhrByteString req /> Ajax.contents >>= \case + Nothing -> + pure $ Network.Failure "Could not send login request." + Just json -> + pure $ Network.fromEither + $ either (Left . ms) pure + $ eitherDecodeStrict json where req = - Request - { reqMethod = GET, - reqURI = "/api/comic", -- FIXME: can we replace this hardcoding? - reqLogin = Nothing, - reqHeaders = [], - reqWithCredentials = False, - reqData = NoData + Ajax.Request + { Ajax.reqMethod = Ajax.POST, + Ajax.reqURI = "/login-hook", + Ajax.reqLogin = Nothing, -- FIXME + Ajax.reqHeaders = + [ ("Accept", "application/json"), + ("Content-Type", "application/json") + ], + Ajax.reqWithCredentials = False, + -- TODO: make this use Aeson + Ajax.reqData = + Ajax.StringData $ + Miso.String.concat + [ "{\"loginEmail\": \"", + u, + "\", \"loginPass\": \"", + p, + "\"}" + ] } diff --git a/Hero/Server.hs b/Hero/Server.hs index 97ce7a2..d179cd2 100644 --- a/Hero/Server.hs +++ b/Hero/Server.hs @@ -1,11 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -27,6 +33,8 @@ -- : dep protolude -- : dep safecopy -- : dep servant +-- : dep servant-auth +-- : dep servant-auth-server -- : dep servant-lucid -- : dep servant-server -- : dep split @@ -38,13 +46,16 @@ -- : dep wai-extra -- : dep wai-middleware-metrics -- : dep warp +-- : dep x509 module Hero.Server where import Alpha -import Biz.App (CSS(..), Manifest(..)) +import Biz.App (CSS (..), Manifest (..)) import qualified Clay +import qualified Crypto.JOSE.JWK as Crypto import Data.Acid (AcidState) import qualified Data.Acid.Abstract as Acid +import qualified Data.Aeson as Aeson import Data.Text (Text) import qualified Data.Text.Lazy as Lazy import Hero.App @@ -61,6 +72,8 @@ import Network.Wai import Network.Wai.Application.Static import qualified Network.Wai.Handler.Warp as Warp import Servant +import qualified Servant.Auth.Server as Auth +import qualified System.Directory as Directory import qualified System.Envy as Envy import qualified System.Exit as Exit import qualified System.IO as IO @@ -72,26 +85,55 @@ main = bracket startup shutdown run prn = IO.hPutStrLn IO.stderr startup = Envy.decodeEnv >>= \case Left e -> Exit.die e - Right cfg -> do - keep <- Keep.open (heroKeep cfg) - say "hero" - prn $ "port: " ++ show (heroPort cfg) - prn $ "beam: " ++ heroBeam cfg - prn $ "keep: " ++ heroKeep cfg - let waiapp = mkApp keep cfg - return (cfg, waiapp, keep) + Right cfg -> + do + keep <- Keep.open (heroKeep cfg) + skey <- upsertKey (heroSkey cfg) + say "hero" + prn $ "port: " ++ show (heroPort cfg) + prn $ "beam: " ++ heroBeam cfg + prn $ "keep: " ++ heroKeep cfg + prn $ "skey: " ++ heroSkey cfg + let jwts = Auth.defaultJWTSettings skey + cs = Auth.defaultCookieSettings + ctx = cs :. jwts :. EmptyContext + proxy = Proxy @(AllRoutes '[Auth.JWT]) + static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg + server = + static + :<|> cssHandlers + :<|> (return "hi") + :<|> loginHookHandler cs jwts + :<|> jsonHandlers keep + :<|> publicHandlers + :<|> pure heroManifest + :<|> Tagged handle404 + return + ( cfg, + serveWithContext + proxy + ctx + server, + keep + ) shutdown :: App -> IO () shutdown (_, _, keep) = do Keep.close keep return () +upsertKey :: FilePath -> IO Crypto.JWK +upsertKey fp = Directory.doesFileExist fp >>= \exists -> + if exists + then Auth.readKey fp + else Auth.writeKey fp >> Auth.readKey fp + -- This part is a little confusing. I have: -- -- - 'App' which encapsulates the entire runtime state -- - 'Config' has stuff I can set at startup -- - 'HeroKeep' is the database and any other persistance --- - 'mkApp' take the second two and makes a 'Wai.Application', should really be --- called 'serve', and might need to be Servant's 'hoistServer' thing +-- - the above are then put together in the 'startup' private function in +-- `main` above -- -- I'm sure this can be cleaned up with a monad stack of some sort, but I -- haven't the brain power to think through that. For now, just try and keep @@ -104,29 +146,16 @@ data Config = Config { heroPort :: Warp.Port, heroBeam :: FilePath, - heroKeep :: FilePath + heroKeep :: FilePath, + heroSkey :: FilePath } deriving (Generic, Show) instance Envy.DefConfig Config where - defConfig = Config 3000 "_bild/Hero.Client/static" "_keep" + defConfig = Config 3000 "_bild/Hero.Client/static" "_keep" "/run/hero/skey" instance Envy.FromEnv Config -mkApp :: AcidState Keep.HeroKeep -> Config -> Application -mkApp keep cfg = - serve - (Proxy @AllRoutes) - ( static - :<|> cssHandlers - :<|> jsonHandlers keep - :<|> serverHandlers - :<|> pure heroManifest - :<|> Tagged handle404 - ) - where - static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg - -- | Convert client side routes into server-side web handlers type ServerRoutes = ToServerRoutes ClientRoutes Templated Action @@ -138,10 +167,39 @@ cssHandlers :: Server CssRoute cssHandlers = return . Lazy.toStrict . Clay.render $ Typography.main <> Look.main -type AllRoutes = +type Ping = "ping" :> Get '[JSON] Text + +type LoginHook = + "login-hook" + :> ReqBody '[JSON] LoginForm + :> Post '[JSON] + ( Headers + '[ Header "Set-Cookie" Auth.SetCookie, + Header "Set-Cookie" Auth.SetCookie + ] + User + ) + +loginHookHandler :: + Auth.CookieSettings -> + Auth.JWTSettings -> + LoginForm -> + Handler + ( Headers + '[ Header "Set-Cookie" Auth.SetCookie, + Header "Set-Cookie" Auth.SetCookie + ] + User + ) +loginHookHandler cs jwts = + checkCreds cs jwts + +type AllRoutes auths = ("static" :> Raw) :<|> CssRoute - :<|> JsonApi + :<|> Ping + :<|> LoginHook + :<|> (Auth.Auth auths User :> JsonApi) :<|> ServerRoutes :<|> ("manifest.json" :> Get '[JSON] Manifest) :<|> Raw @@ -231,7 +289,6 @@ instance L.ToHtml a => L.ToHtml (Templated a) where (L.link_ mempty) [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] - handle404 :: Application handle404 _ respond = respond @@ -249,12 +306,15 @@ animateRef :: MisoString animateRef = "https://cdnjs.cloudflare.com/ajax/libs/animate.css/3.7.0/animate.min.css" +-- TODO: if I remove this, then the login form (and probably other stuff) gets +-- messed up. When I remove this, I need to also port the necessary CSS styles +-- to make stuff look good. bulmaRef :: MisoString bulmaRef = "https://cdnjs.cloudflare.com/ajax/libs/bulma/0.7.2/css/bulma.min.css" -serverHandlers :: Server ServerRoutes -serverHandlers = +publicHandlers :: Server ServerRoutes +publicHandlers = homeHandler :<|> comicCoverHandler :<|> comicPageHandler @@ -264,8 +324,35 @@ serverHandlers = :<|> discoverHandler :<|> chooseExperienceHandler -jsonHandlers :: AcidState Keep.HeroKeep -> Server JsonApi -jsonHandlers keep = Acid.query' keep $ Keep.GetComics 10 + +instance Auth.ToJWT User + +instance Auth.FromJWT User + +checkCreds :: + Auth.CookieSettings -> + Auth.JWTSettings -> + LoginForm -> + Handler + ( Headers + '[ Header "Set-Cookie" Auth.SetCookie, + Header "Set-Cookie" Auth.SetCookie + ] + User + ) +checkCreds cookieSettings jwtSettings (LoginForm "ben@bsima.me" "test") = do + -- TODO: get this from keep + liftIO $ say "successful login" + let usr = User "ben@bsima.me" "ben" [] -- TODO: load initial library + mApplyCookies <- liftIO $ Auth.acceptLogin cookieSettings jwtSettings usr + case mApplyCookies of + Nothing -> throwError err401 + Just applyCookies -> return $ applyCookies usr +checkCreds _ _ _ = throwError err401 + +jsonHandlers :: AcidState Keep.HeroKeep -> Auth.AuthResult User -> Server JsonApi +jsonHandlers keep (Auth.Authenticated user) = Acid.query' keep $ Keep.GetComics 10 +jsonHandlers _ _ = Auth.throwAll err401 homeHandler :: Handler (Templated (View Action)) homeHandler = pure . Templated . home $ initModel homeLink @@ -295,4 +382,3 @@ chooseExperienceHandler id n = loginHandler :: Handler (Templated (View Action)) loginHandler = pure . Templated . login $ initModel loginLink - diff --git a/Hero/Service.nix b/Hero/Service.nix index a3c6bd5..e5d811b 100644 --- a/Hero/Service.nix +++ b/Hero/Service.nix @@ -31,6 +31,11 @@ in type = lib.types.package; description = "herocomics-client package to use"; }; + skey = lib.mkOption { + type = lib.types.path; + default = "/run/hero/skey"; + description = "where to store the signing key"; + }; domain = lib.mkOption { type = lib.types.str; default = "herocomics.app"; diff --git a/Miso/Extend.hs b/Miso/Extend.hs new file mode 100644 index 0000000..e7a9ff6 --- /dev/null +++ b/Miso/Extend.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Miso.Extend + ( crossorigin_, + onPreventClick, + ) +where + +import Miso +import Miso.String + +-- | HTML crossorigin attribute +-- +-- https://developer.mozilla.org/en-US/docs/Web/HTML/Attributes/crossorigin +crossorigin_ :: MisoString -> Attribute action +crossorigin_ = textProp "crossorigin" + +-- | 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) @@ -1,5 +1,5 @@ #!/usr/bin/env bash -set -ex +set -exo pipefail prefix=$(echo $PWD | sed -e "s|^$BIZ_ROOT/*||g" -e "s|/|.|g") if [[ "$prefix" == "" ]] then diff --git a/nix/haskell-deps.nix b/nix/haskell-deps.nix index 44c2050..26981dc 100644 --- a/nix/haskell-deps.nix +++ b/nix/haskell-deps.nix @@ -33,6 +33,8 @@ "safecopy" "scotty" "servant" + "servant-auth" + "servant-auth-server" "servant-lucid" "servant-server" "split" @@ -50,4 +52,5 @@ "wai-extra" "wai-middleware-metrics" "warp" + "x509" ] diff --git a/nix/haskell-overlay.nix b/nix/haskell-overlay.nix index 1afea87..f37d602 100644 --- a/nix/haskell-overlay.nix +++ b/nix/haskell-overlay.nix @@ -1,20 +1,27 @@ _: pkgs: let - cabalBuilder = self: name: self.callCabal2nix name pkgs.sources.${name} {}; + simpleCabalBuilder = self: name: + self.callCabal2nix name pkgs.sources.${name} {}; + buildCabal = self: name: subdir: + if isNull subdir then + self.callCabal2nix name pkgs.sources.${name} {} + else + self.callCabal2nix name (pkgs.sources.${name} + "/${subdir}") {}; in { haskell = pkgs.haskell // { packages = pkgs.haskell.packages // { ghc865 = pkgs.haskell.packages.ghc865.override (old: { overrides = with pkgs.pkgs.haskell.lib; self: super: - pkgs.overridePinnedDeps (cabalBuilder self) // { + pkgs.overridePinnedDeps (simpleCabalBuilder self) // { + servant-auth = buildCabal self "servant-auth" "servant-auth"; wai-middleware-metrics = dontCheck super.wai-middleware-metrics; }; }); ghcjs = pkgs.haskell.packages.ghcjs.override (old: { overrides = with pkgs.haskell.lib; self: super: - pkgs.overridePinnedDeps (cabalBuilder self) // { + pkgs.overridePinnedDeps (simpleCabalBuilder self) // { QuickCheck = dontCheck super.QuickCheck; base-compat-batteries = dontCheck super.http-types; clay = dontCheck super.clay; diff --git a/nix/sources.json b/nix/sources.json index 195a218..fdbb4b6 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -62,6 +62,18 @@ "url": "https://github.com/NixOS/nixpkgs/archive/b0c285807d6a9f1b7562ec417c24fa1a30ecc31a.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" }, + "servant-auth": { + "branch": "master", + "description": null, + "homepage": null, + "owner": "haskell-servant", + "repo": "servant-auth", + "rev": "696fab268e21f3d757b231f0987201b539c52621", + "sha256": "1had0xyh511q7ggw2mlfhhk7pfbc30gqm2c9gj1y7pbflmsjgjda", + "type": "tarball", + "url": "https://github.com/haskell-servant/servant-auth/archive/696fab268e21f3d757b231f0987201b539c52621.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + }, "wemux": { "branch": "master", "description": "Multi-User Tmux Made Easy", |