diff options
author | Ben Sima <ben@bsima.me> | 2020-06-01 22:22:13 -0700 |
---|---|---|
committer | Ben Sima <ben@bsima.me> | 2020-06-02 11:35:19 -0700 |
commit | 78774e835ac0c564cf52a5e6dd0bf22b56761c4d (patch) | |
tree | 942c1a591c2e8792e7bf9b1a16eccbecf52b0efa /Hero/Database.hs | |
parent | 6aa4f1890a4e1327b5eabfb19386c94750223cbe (diff) |
Initialize Hero database
Diffstat (limited to 'Hero/Database.hs')
-rw-r--r-- | Hero/Database.hs | 105 |
1 files changed, 74 insertions, 31 deletions
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 |