diff options
| -rw-r--r-- | .envrc | 1 | ||||
| -rw-r--r-- | Alpha.hs | 2 | ||||
| -rw-r--r-- | Biz/Ibb/Keep.hs | 5 | ||||
| -rw-r--r-- | Hero/App.hs | 38 | ||||
| -rw-r--r-- | Hero/Database.hs | 105 | ||||
| -rw-r--r-- | Hero/Server.hs | 35 | ||||
| -rw-r--r-- | Hero/Service.nix | 6 | ||||
| -rw-r--r-- | default.nix | 3 |
8 files changed, 139 insertions, 56 deletions
@@ -3,6 +3,7 @@ export NIX_PATH=$PWD/nix export BIZ_ROOT=$PWD export HERO_PORT=3000 export HERO_CLIENT=$BIZ_ROOT/_bild/Hero.Client/static +export HERO_DATA_DIR=$BIZ_ROOT/_keep export GUILE_LOAD_PATH=$PWD if type lorri &>/dev/null then @@ -97,4 +97,4 @@ joinWith = intercalate -- | can you just not don't :: Bool -> Bool don't = do not -{-# ANN don't "HLint: ignore Redundant do" #-} +{-# ANN don't ("HLint: ignore Redundant do" :: String) #-} diff --git a/Biz/Ibb/Keep.hs b/Biz/Ibb/Keep.hs index 8ee1228..c7dabb0 100644 --- a/Biz/Ibb/Keep.hs +++ b/Biz/Ibb/Keep.hs @@ -11,6 +11,7 @@ -- like `$(keep ''MyType)`. module Biz.Ibb.Keep where +import Alpha import Biz.Ibb.Core (Book (..), Person (..)) import qualified Biz.Ibb.Influencers as Influencers import Control.Monad.Reader (ask) @@ -61,7 +62,7 @@ instance Indexable Person where -- | updates the `IbbKeep` with a new `Person` newPerson :: Text -> Text -> Update IbbKeep Person newPerson name blurb = do - k <- get + keep <- get put $ k { _people = IxSet.insert p (_people k) @@ -79,7 +80,7 @@ newPerson name blurb = do } getPeople :: Int -> Acid.Query IbbKeep [Person] -getPeople n = take n $ IxSet.toList $ _people keep </ ask +getPeople n = ask /> _people /> IxSet.toList /> take n -- * Index @Book@ diff --git a/Hero/App.hs b/Hero/App.hs index a254d80..3aca8be 100644 --- a/Hero/App.hs +++ b/Hero/App.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} @@ -19,6 +21,7 @@ import Data.Aeson genericParseJSON, genericToJSON, ) +import Data.Data (Data, Typeable) import qualified Data.List as List import qualified Data.List.Split as List import Data.Proxy (Proxy (..)) @@ -39,6 +42,8 @@ import Servant.API ( (:<|>) (..), (:>), Capture, + ToHttpApiData, + FromHttpApiData, URI (..), safeLink, ) @@ -62,7 +67,26 @@ onPreventClick action = (\() -> action) -- TODO: make ComicId a hashid https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html -type ComicId = String +newtype ComicId + = ComicId String + deriving + ( Show, + Eq, + Ord, + Data, + Typeable, + Generic, + ToMisoString, + IsString, + ToHttpApiData, + FromHttpApiData + ) + +instance ToJSON ComicId where + toJSON = genericToJSON Data.Aeson.defaultOptions + +instance FromJSON ComicId where + parseJSON = genericParseJSON Data.Aeson.defaultOptions -- | Class for turning different string types to snakeCase. class CanSnakeCase str where @@ -84,7 +108,7 @@ data Comic comicIssue :: Text, comicDescription :: Text } - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Data, Ord) instance ToJSON Comic where toJSON = genericToJSON Data.Aeson.defaultOptions @@ -317,11 +341,11 @@ initModel uri_ = -- | Hacky way to initialize the 'ComicReaderState' from the URI. detectPlayerState :: URI -> ComicReaderState detectPlayerState u = case List.splitOn "/" $ uriPath u of - ["", "comic", id, pg, "experience"] -> ChooseExperience id $ toPage pg - ["", "comic", id, _, "video"] -> Watching id - ["", "comic", id, pg, "full"] -> Reading Full id $ toPage pg - ["", "comic", id, pg] -> Reading Spread id $ toPage pg - ["", "comic", id] -> Cover id + ["", "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) + ["", "comic", id, pg] -> Reading Spread (ComicId id) (toPage pg) + ["", "comic", id] -> Cover $ ComicId id _ -> NotReading where toPage pg = fromMaybe 1 (readMaybe pg :: Maybe Page) diff --git a/Hero/Database.hs b/Hero/Database.hs index 5b7f75d..e3c765c 100644 --- a/Hero/Database.hs +++ b/Hero/Database.hs @@ -1,43 +1,86 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hero.Database - ( ComicDB, + ( HeroKeep, + GetComics(..), getComics, - load, - dummy, + NewComic(..), + newComic, + openLocal, ) where -import Data.Map (Map) -import qualified Data.Map as Map -import Dhall +import Alpha +import qualified Data.Acid as Acid +import Data.Acid (Update, makeAcidic) +import Data.Data (Data, Typeable) +import qualified Data.IxSet as IxSet +import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet) +import Data.SafeCopy (base, deriveSafeCopy) +import qualified Data.Text as Text import Hero.App -import Protolude -import Servant (Handler) - -type ComicDB = (Map ComicId Comic) - -instance Interpret Comic - -load :: IO ComicDB -load = listToComicDB <$> input auto "./comic-database.dhall" - -dummy :: IO ComicDB -dummy = - return $ - listToComicDB - [ Comic - { comicId = "ComicId", - comicPages = 10, - comicName = "Dummy comic", - comicIssue = "dummy issue", - comicDescription = "Lorem ipsum" - } + +-- * Keep + +-- | Main database. +newtype HeroKeep + = HeroKeep + {_comics :: (IxSet Comic)} + deriving (Data, Typeable) + +$(deriveSafeCopy 0 'base ''HeroKeep) + +-- * Index @Comic@ + +$(deriveSafeCopy 0 'base ''Comic) + +$(deriveSafeCopy 0 'base ''ComicId) + +instance Indexable Comic where + empty = + ixSet + [ ixFun $ \c -> [comicId c], + ixFun $ \c -> [comicPages c], + ixFun $ \c -> [comicName c], + ixFun $ \c -> [comicIssue c], + ixFun $ \c -> [comicDescription c] ] -listToComicDB :: [Comic] -> ComicDB -listToComicDB ls = Map.fromList $ (,) <$> comicId <*> identity <$> ls +newComic :: Comic -> Update HeroKeep Comic +newComic c = do + keep <- get + put $ keep {_comics = IxSet.insert c (_comics keep)} + return c + +getComics :: Int -> Acid.Query HeroKeep [Comic] +getComics n = ask /> _comics /> IxSet.toList /> take n + +-- * Opening the keep + +$(makeAcidic ''HeroKeep ['newComic, 'getComics]) + +initialHeroKeep :: HeroKeep +initialHeroKeep = HeroKeep {_comics = IxSet.fromList [theRed] } + where + theRed = + Comic + { comicId = "1", + comicPages = 42, + comicName = "The Red", + comicIssue = "1.0", + comicDescription = + Text.unlines + [ "In the future, a nuclear world war has changed the course", + "of history forever. A single government entity now presides", + "over what's left of the world, and prohibits certain content", + "that is deemed emotionall dangerous, or \"red\", in attempt", + "to maintain order and keep society working..." + ] + } -getComics :: ComicDB -> Handler [Comic] -getComics db = return $ Map.elems db +openLocal :: String -> IO (Acid.AcidState HeroKeep) +openLocal dir = Acid.openLocalStateFrom dir initialHeroKeep diff --git a/Hero/Server.hs b/Hero/Server.hs index 4dc80f5..73108be 100644 --- a/Hero/Server.hs +++ b/Hero/Server.hs @@ -13,17 +13,19 @@ -- -- : exe mmc -- +-- : dep acid-state -- : dep aeson -- : dep clay -- : dep containers --- : dep dhall -- : dep envy -- : dep http-types +-- : dep ixset -- : dep lucid -- : dep miso -- : dep mtl -- : dep network-uri -- : dep protolude +-- : dep safecopy -- : dep servant -- : dep servant-lucid -- : dep servant-server @@ -40,6 +42,8 @@ module Hero.Server where import qualified Clay import Data.Aeson +import Data.Acid (AcidState) +import qualified Data.Acid.Abstract as Acid import Data.Proxy import Data.Text (Text) import qualified Data.Text.Lazy as Lazy @@ -74,13 +78,14 @@ main = bracket startup shutdown $ uncurry Warp.run say = IO.hPutStrLn IO.stderr startup = Envy.decodeEnv >>= \case Left e -> Exit.die e - Right c -> do - db <- Database.dummy + Right cfg -> do + keep <- Database.openLocal (heroDataDir cfg) say "hero" - say $ "port: " ++ show (heroPort c) - say $ "client: " ++ heroClient c - let waiapp = app db c - return (heroPort c, waiapp) + 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 @@ -89,22 +94,24 @@ data Config { -- | HERO_PORT heroPort :: Warp.Port, -- | HERO_CLIENT - heroClient :: FilePath + heroClient :: FilePath, + -- | HERO_DATA + heroDataDir :: FilePath } deriving (Generic, Show) instance Envy.DefConfig Config where - defConfig = Config 3000 "_bild/Hero.Client/static" + defConfig = Config 3000 "_bild/Hero.Client/static" "_keep" instance Envy.FromEnv Config -app :: Database.ComicDB -> Config -> Application -app db cfg = +app :: AcidState Database.HeroKeep -> Config -> Application +app keep cfg = serve (Proxy @AllRoutes) ( static :<|> cssHandlers - :<|> jsonHandlers db + :<|> jsonHandlers keep :<|> serverHandlers :<|> pure heroManifest :<|> Tagged handle404 @@ -272,8 +279,8 @@ serverHandlers = :<|> discoverHandler :<|> chooseExperienceHandler -jsonHandlers :: Database.ComicDB -> Server JsonApi -jsonHandlers = Database.getComics +jsonHandlers :: AcidState Database.HeroKeep -> Server JsonApi +jsonHandlers keep = Acid.query' keep $ Database.GetComics 10 homeHandler :: Handler (HtmlPage (View Action)) homeHandler = pure . HtmlPage . home $ initModel homeLink diff --git a/Hero/Service.nix b/Hero/Service.nix index f0f4227..8bad6d7 100644 --- a/Hero/Service.nix +++ b/Hero/Service.nix @@ -18,6 +18,11 @@ in The port on which herocomics-server will listen for incoming HTTP traffic. ''; }; + dataDir = lib.mkOption { + type = lib.types.path; + default = "/var/lib/hero"; + description = "herocomics-server database directory"; + }; server = lib.mkOption { type = lib.types.package; description = "herocomics-server package to use"; @@ -50,6 +55,7 @@ in Environment = [ "HERO_CLIENT=${cfg.client}/static" "HERO_PORT=${toString cfg.port}" + "HERO_DATA_DIR=${cfg.dataDir}" ]; Type = "simple"; Restart = "on-abort"; diff --git a/default.nix b/default.nix index f274f81..4fa9e0a 100644 --- a/default.nix +++ b/default.nix @@ -69,12 +69,13 @@ in rec { ./Hero/Prod.nix ]; networking.hostName = "prod-herocomics"; - networking.domain = "herocomcis.app"; + networking.domain = "herocomics.app"; services.herocomics = { enable = true; port = 3000; server = Hero.Server; client = Hero.Client; + dataDir = "/var/lib/hero"; }; }; # Haskell targets |