diff options
| -rw-r--r-- | Hero/App.hs | 59 | ||||
| -rw-r--r-- | Hero/Client.hs | 10 | ||||
| -rw-r--r-- | Hero/Keep.hs | 39 | ||||
| -rw-r--r-- | Hero/Server.hs | 51 | ||||
| -rw-r--r-- | Hero/Service.nix | 14 | ||||
| -rw-r--r-- | default.nix | 6 |
6 files changed, 120 insertions, 59 deletions
diff --git a/Hero/App.hs b/Hero/App.hs index 3aca8be..da2289c 100644 --- a/Hero/App.hs +++ b/Hero/App.hs @@ -37,7 +37,6 @@ import Miso import qualified Miso (for_) import Miso.String import Network.RemoteData -import Protolude hiding (replace) import Servant.API ( (:<|>) (..), (:>), @@ -99,6 +98,29 @@ instance CanSnakeCase Text where comicSlug :: Comic -> Text comicSlug Comic {..} = snake comicName <> "-" <> comicIssue +data User + = User + { userEmail :: Text, + userName :: Text, + userLibrary :: [Comic] + } + 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) + +instance Monoid User where + mempty = User mempty mempty mempty + +instance ToJSON User where + toJSON = genericToJSON Data.Aeson.defaultOptions + +instance FromJSON User where + parseJSON = genericParseJSON Data.Aeson.defaultOptions + data Comic = Comic { comicId :: ComicId, @@ -122,10 +144,10 @@ class IsMediaObject o where thumbnail :: o -> View Action -- | Render a featured banner. - feature :: o -> Library -> View Action + feature :: o -> User -> View Action -- | Media info view - info :: o -> Library -> View Action + info :: o -> User -> View Action instance IsMediaObject Comic where thumbnail c@Comic {..} = @@ -200,8 +222,8 @@ type ZoomModel = Int data Button = Watch Comic | Read Comic - | Save Comic Library - | SaveIcon Comic Library + | Save Comic User + | SaveIcon Comic User | ZoomIcon ZoomModel Comic Page | PlayPause MisoString AudioState | Arrow Action @@ -231,8 +253,8 @@ instance Elemental Button where PrevPage -> "prev-page" NextPage -> "next-page" _ -> "prev-page" - el (Save c lib) = - if c `elem` lib -- in library + el (Save c u) = + if c `elem` (userLibrary u) -- in library then a_ [class_ "wrs-button saved", onClick $ ToggleInLibrary c] @@ -246,8 +268,8 @@ instance Elemental Button where [ img_ [src_ $ ms $ Assets.icon <> "save.svg"], span_ [] [text "save"] ] - el (SaveIcon c lib) = - if c `elem` lib -- in library + el (SaveIcon c u) = + if c `elem` (userLibrary u) -- in library then button_ [ class_ "button is-large has-background-black", @@ -297,8 +319,6 @@ instance Elemental Button where data AudioState = Playing | Paused deriving (Show, Eq) -type Library = [Comic] - data ComicReaderState = NotReading | Cover ComicId @@ -318,7 +338,7 @@ data Model = Model { uri :: URI, appComics :: RemoteData MisoString [Comic], - userLibrary :: Library, + user :: User, dMediaInfo :: Maybe Comic, cpState :: ComicReaderState, cpAudioState :: AudioState, @@ -332,7 +352,7 @@ initModel uri_ = { uri = uri_, appComics = NotAsked, dMediaInfo = Nothing, - userLibrary = Protolude.empty, + user = mempty, cpState = detectPlayerState uri_, cpAudioState = Paused, zoomModel = 100 @@ -466,7 +486,7 @@ home :: Model -> View Action home = login discover :: Model -> View Action -discover model@Model {userLibrary = lib} = +discover model@Model {user = u} = template "discover" [ topbar, @@ -476,9 +496,9 @@ discover model@Model {userLibrary = lib} = Failure _ -> [nocomics] Success [] -> [nocomics] Success (comic : rest) -> - [ feature comic lib, + [ feature comic u, shelf "Recent Releases" (comic : rest), - maybeView (`info` lib) $ dMediaInfo model + maybeView (`info` u) $ dMediaInfo model ], appmenu, discoverFooter @@ -488,9 +508,10 @@ discover model@Model {userLibrary = lib} = maybeView :: (a -> View action) -> Maybe a -> View action maybeView = maybe (text "") -mediaInfo :: Maybe Comic -> Library -> View Action +mediaInfo :: Maybe Comic -> User -> View Action mediaInfo Nothing _ = text "" -mediaInfo (Just comic) lib = div_ [class_ "media-info"] [info comic lib] +mediaInfo (Just comic) user = + div_ [class_ "media-info"] [info comic user] appmenu :: View Action appmenu = aside_ [id_ "appmenu"] $ btn </ links @@ -712,7 +733,7 @@ comicControls comic page model = ], div_ [class_ "comic-controls-share"] - [ el $ SaveIcon comic $ userLibrary model, + [ el $ SaveIcon comic $ user model, el $ ZoomIcon (zoomModel model) comic page, button_ [class_ "button icon is-large", onClick ToggleFullscreen] diff --git a/Hero/Client.hs b/Hero/Client.hs index a513dcd..4189fd8 100644 --- a/Hero/Client.hs +++ b/Hero/Client.hs @@ -28,6 +28,7 @@ import Hero.App ComicReaderState (..), ComicReaderView (..), Model (..), + User (..), audioId, chooseExperienceLink, comicPlayerFullLink, @@ -130,12 +131,13 @@ move (ToggleZoom c pg) m = m {cpState = newState} <# pure act Reading Full _ _ -> (reading Spread, goto comicPlayerSpreadLink) Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink) x -> (x, NoOp) -move (ToggleInLibrary c) model = model {userLibrary = newLib} <# pure NoOp +move (ToggleInLibrary c) model = model {user = newUser} <# pure NoOp where + newUser = (user model) { userLibrary = newLib } newLib - | c `elem` userLibrary model = - Protolude.filter (/= c) $ userLibrary model - | otherwise = c : userLibrary model + | c `elem` (userLibrary $ user model) = + Protolude.filter (/= c) $ userLibrary $ user model + | otherwise = c : (userLibrary $ user model) move (HandleURI u) model = model {uri = u} <# pure NoOp move (ChangeURI u) model = model <# do pushURI u diff --git a/Hero/Keep.hs b/Hero/Keep.hs index 9ac46fa..ee625d8 100644 --- a/Hero/Keep.hs +++ b/Hero/Keep.hs @@ -6,11 +6,12 @@ module Hero.Keep ( HeroKeep, - GetComics(..), + GetComics (..), getComics, - NewComic(..), + NewComic (..), newComic, - openLocal, + open, + close, ) where @@ -27,9 +28,11 @@ import Hero.App -- * Keep -- | Main database. -newtype HeroKeep +data HeroKeep = HeroKeep - {_comics :: (IxSet Comic)} + { _comics :: (IxSet Comic), + _users :: (IxSet User) + } deriving (Data, Typeable) $(deriveSafeCopy 0 'base ''HeroKeep) @@ -38,6 +41,8 @@ $(deriveSafeCopy 0 'base ''HeroKeep) $(deriveSafeCopy 0 'base ''Comic) +$(deriveSafeCopy 0 'base ''User) + $(deriveSafeCopy 0 'base ''ComicId) instance Indexable Comic where @@ -50,6 +55,14 @@ instance Indexable Comic where ixFun $ \c -> [comicDescription c] ] +instance Indexable User where + empty = + ixSet + [ ixFun $ \u -> [userEmail u], + ixFun $ \u -> [userName u], + ixFun $ \u -> [userLibrary u] + ] + newComic :: Comic -> Update HeroKeep Comic newComic c = do keep <- get @@ -64,7 +77,14 @@ getComics n = ask /> _comics /> IxSet.toList /> take n $(makeAcidic ''HeroKeep ['newComic, 'getComics]) initialHeroKeep :: HeroKeep -initialHeroKeep = HeroKeep {_comics = IxSet.fromList [theRed] } +initialHeroKeep = + HeroKeep + { _comics = IxSet.fromList [theRed], + _users = IxSet.fromList + [ User "a" "micheal" [], + User "b" "ben" [] + ] + } where theRed = Comic @@ -82,5 +102,8 @@ initialHeroKeep = HeroKeep {_comics = IxSet.fromList [theRed] } ] } -openLocal :: String -> IO (Acid.AcidState HeroKeep) -openLocal dir = Acid.openLocalStateFrom dir initialHeroKeep +open :: String -> IO (Acid.AcidState HeroKeep) +open dir = Acid.openLocalStateFrom dir initialHeroKeep + +close :: Acid.AcidState HeroKeep -> IO () +close = Acid.closeAcidState diff --git a/Hero/Server.hs b/Hero/Server.hs index d663c37..351e839 100644 --- a/Hero/Server.hs +++ b/Hero/Server.hs @@ -41,9 +41,9 @@ module Hero.Server where import qualified Clay -import Data.Aeson 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 @@ -73,30 +73,45 @@ import qualified System.Exit as Exit import qualified System.IO as IO main :: IO () -main = bracket startup shutdown $ uncurry Warp.run +main = bracket startup shutdown run where + run (cfg, app, _) = Warp.run (heroPort cfg) app say = IO.hPutStrLn IO.stderr startup = Envy.decodeEnv >>= \case Left e -> Exit.die e Right cfg -> do - keep <- Keep.openLocal (heroDataDir cfg) + keep <- Keep.open (heroKeep cfg) say "hero" say $ "port: " ++ show (heroPort cfg) - say $ "client: " ++ heroClient cfg - say $ "data: " ++ heroDataDir cfg - let waiapp = app keep cfg - return (heroPort cfg, waiapp) - shutdown :: a -> IO a - shutdown = pure . identity + say $ "beam: " ++ heroBeam cfg + say $ "keep: " ++ heroKeep cfg + let waiapp = mkApp keep cfg + return (cfg, waiapp, keep) + shutdown :: App -> IO () + shutdown (_, _, keep) = do + Keep.close keep + return () + +-- 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 +-- +-- 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 +-- things named clearly so I don't get confused. + +-- | This can be generalized I think, put in Biz.App, or something +type App = (Config, Application, AcidState Keep.HeroKeep) data Config = Config - { -- | HERO_PORT - heroPort :: Warp.Port, - -- | HERO_CLIENT - heroClient :: FilePath, - -- | HERO_DATA - heroDataDir :: FilePath + { heroPort :: Warp.Port, + heroBeam :: FilePath, + heroKeep :: FilePath } deriving (Generic, Show) @@ -105,8 +120,8 @@ instance Envy.DefConfig Config where instance Envy.FromEnv Config -app :: AcidState Keep.HeroKeep -> Config -> Application -app keep cfg = +mkApp :: AcidState Keep.HeroKeep -> Config -> Application +mkApp keep cfg = serve (Proxy @AllRoutes) ( static @@ -117,7 +132,7 @@ app keep cfg = :<|> Tagged handle404 ) where - static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg + static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg -- | HtmlPage for setting HTML doctype and header newtype HtmlPage a = HtmlPage a diff --git a/Hero/Service.nix b/Hero/Service.nix index 8bad6d7..a3c6bd5 100644 --- a/Hero/Service.nix +++ b/Hero/Service.nix @@ -18,16 +18,16 @@ in The port on which herocomics-server will listen for incoming HTTP traffic. ''; }; - dataDir = lib.mkOption { + keep = lib.mkOption { type = lib.types.path; default = "/var/lib/hero"; description = "herocomics-server database directory"; }; - server = lib.mkOption { + deck = lib.mkOption { type = lib.types.package; description = "herocomics-server package to use"; }; - client = lib.mkOption { + beam = lib.mkOption { type = lib.types.package; description = "herocomics-client package to use"; }; @@ -42,10 +42,10 @@ in }; config = lib.mkIf cfg.enable { systemd.services.herocomics = { - path = [ cfg.server ]; + path = [ cfg.deck ]; wantedBy = [ "multi-user.target" ]; script = '' - ${cfg.server}/bin/mmc + ${cfg.deck}/bin/mmc ''; description = '' Hero Comics app server @@ -53,9 +53,9 @@ in serviceConfig = { KillSignal = "INT"; Environment = [ - "HERO_CLIENT=${cfg.client}/static" + "HERO_BEAM=${cfg.beam}/static" "HERO_PORT=${toString cfg.port}" - "HERO_DATA_DIR=${cfg.dataDir}" + "HERO_KEEP=${cfg.keep}" ]; Type = "simple"; Restart = "on-abort"; diff --git a/default.nix b/default.nix index 4fa9e0a..32f9952 100644 --- a/default.nix +++ b/default.nix @@ -73,9 +73,9 @@ in rec { services.herocomics = { enable = true; port = 3000; - server = Hero.Server; - client = Hero.Client; - dataDir = "/var/lib/hero"; + deck = Hero.Server; + beam = Hero.Client; + keep = "/var/lib/hero"; }; }; # Haskell targets |